packages feed

sandwich-contexts-kubernetes (empty) → 0.1.0.0

raw patch · 36 files changed

+4222/−0 lines, 36 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, exceptions, filepath, http-client, kubernetes-client, kubernetes-client-core, lens, lens-aeson, minio-hs, monad-logger, network, network-uri, process, random, regex-tdfa, relude, retry, safe, sandwich, sandwich-contexts, sandwich-contexts-kubernetes, sandwich-contexts-minio, string-interpolate, temporary, text, unliftio, unliftio-core, vector, yaml

Files

+ lib/Test/Sandwich/Contexts/Kubernetes.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}++{-|++Create Kubernetes clusters with either [kind](https://kind.sigs.k8s.io/) or [Minikube](https://kubernetes.io/docs/tutorials/hello-minikube/), obtaining the relevant binary from either the current PATH or from Nix.++Also contains functions for waiting for pods and services to exist, running commands with [kubectl](https://kubernetes.io/docs/reference/kubectl/), logging, service forwarding, and port forwarding.++-}++module Test.Sandwich.Contexts.Kubernetes (+  -- * Kind clusters+  Kind.introduceKindClusterViaNix+  , Kind.introduceKindClusterViaEnvironment+  , Kind.introduceKindCluster'++  , Kind.defaultKindClusterOptions+  , Kind.KindClusterOptions(..)++  -- * Minikube clusters+  , Minikube.introduceMinikubeClusterViaNix+  , Minikube.introduceMinikubeClusterViaEnvironment+  , Minikube.introduceMinikubeCluster'++  , Minikube.defaultMinikubeClusterOptions+  , Minikube.MinikubeClusterOptions(..)++  -- * Wait for pods/services+  , waitForPodsToExist+  , waitForPodsToBeReady+  , waitForServiceEndpointsToExist++  -- * Run commands with kubectl+  , askKubectlArgs+  , askKubectlEnvironment++  -- * Forward services+  , withForwardKubernetesService+  , withForwardKubernetesService'++  -- * Logs+  , module Test.Sandwich.Contexts.Kubernetes.KubectlLogs++  -- * Port forwarding+  , module Test.Sandwich.Contexts.Kubernetes.KubectlPortForward++  -- * Types+  , kubernetesCluster+  , KubernetesClusterContext(..)+  , KubernetesClusterType(..)+  , HasKubernetesClusterContext++  -- * Constraint aliases+  , KubernetesBasic+  , KubernetesClusterBasic+  , KubectlBasic+  , NixContextBasic+  , KubernetesBasicWithoutReader+  , KubernetesClusterBasicWithoutReader+  , KubectlBasicWithoutReader+  ) where++import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Network.URI+import Relude+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Kubectl+import Test.Sandwich.Contexts.Kubernetes.KubectlLogs+import Test.Sandwich.Contexts.Kubernetes.KubectlPortForward+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Waits++import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster as Kind+import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardPortForward as Kind++import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster as Minikube+import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Forwards as Minikube+++-- | Forward a Kubernetes service, so that it can be reached at a local URI.+withForwardKubernetesService :: (+  MonadMask m, KubectlBasic context m+  )+  -- | Namespace+  => Text+  -- | Service name+  -> Text+  -- | Callback receiving the service 'URL'.+  -> (URI -> m a)+  -> m a+withForwardKubernetesService namespace serviceName action = do+  kcc <- getContext kubernetesCluster+  kubectlBinary <- askFile @"kubectl"+  withForwardKubernetesService' kcc kubectlBinary namespace serviceName action++-- | Same as 'withForwardKubernetesService', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary.+withForwardKubernetesService' :: (+  MonadLoggerIO m, MonadMask m, MonadUnliftIO m+  , HasBaseContextMonad context m+  )+  -- | Kubernetes cluster context+  => KubernetesClusterContext+  -- | Binary path for kubectl+  -> FilePath+  -- | Namespace+  -> Text+  -- | Service name+  -> Text+  -- | Callback receiving the service 'URL'.+  -> (URI -> m a)+  -> m a+withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) _kubectlBinary =+  Minikube.withForwardKubernetesService' kcc kubernetesClusterTypeMinikubeProfileName+withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary =+  Kind.withForwardKubernetesService' kcc kubectlBinary
+ lib/Test/Sandwich/Contexts/Kubernetes/FindImages.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.FindImages (+  findAllImages+  , findAllImages'+  ) where++import Control.Lens+import Data.Aeson (FromJSON)+import qualified Data.Aeson as A+import Data.Aeson.Lens+import Data.Text as T+import qualified Data.Yaml as Yaml+import Kubernetes.OpenAPI.Model as Kubernetes+import Kubernetes.OpenAPI.ModelLens as Kubernetes+import Relude+import Test.Sandwich.Contexts.Kubernetes.Util.Aeson+++-- | Find all image references in a chunk of YAML containing multiple sections.+findAllImages :: Text -> [Text]+findAllImages = Relude.concatMap findAllImages' . T.splitOn "---\n"++-- | Find all image references in a single chunk of YAML.+findAllImages' :: Text -> [Text]+findAllImages' (decode -> Right x@(V1Pod {v1PodKind=(Just "Pod")})) = maybe [] imagesFromPodSpec (v1PodSpec x)+findAllImages' (decode -> Right x@(V1Deployment {v1DeploymentKind=(Just "Deployment")})) = maybe [] imagesFromPodSpec maybePodSpec+  where+    maybePodSpec :: Maybe V1PodSpec+    maybePodSpec = x ^? (v1DeploymentSpecL . _Just . v1DeploymentSpecTemplateL . v1PodTemplateSpecSpecL . _Just)+findAllImages' (decode -> Right x@(V1StatefulSet {v1StatefulSetKind=(Just "StatefulSet")})) = maybe [] imagesFromPodSpec maybePodSpec+  where+    maybePodSpec :: Maybe V1PodSpec+    maybePodSpec = x ^? (v1StatefulSetSpecL . _Just . v1StatefulSetSpecTemplateL . v1PodTemplateSpecSpecL . _Just)+findAllImages' (decode -> Right x@(V1DaemonSet {v1DaemonSetKind=(Just "DaemonSet")})) = maybe [] imagesFromPodSpec maybePodSpec+  where+    maybePodSpec :: Maybe V1PodSpec+    maybePodSpec = x ^? (v1DaemonSetSpecL . _Just . v1DaemonSetSpecTemplateL . v1PodTemplateSpecSpecL . _Just)++-- Pick up images in MinIO "Tenant" CRDs+findAllImages' (decode -> Right x@(A.Object obj))+  | Just (A.String "Tenant") <- aesonLookup "kind" obj+    , Just (A.String img) <- x ^? (_Object . ix "spec" . _Object . ix "image") = [img]++findAllImages' _ = []++imagesFromPodSpec :: V1PodSpec -> [Text]+imagesFromPodSpec x = mapMaybe v1ContainerImage allContainers+  where+    allContainers = x ^. v1PodSpecContainersL <> fromMaybe [] (x ^. v1PodSpecInitContainersL)++decode :: FromJSON a => Text -> Either Yaml.ParseException a+decode = Yaml.decodeEither' . encodeUtf8
+ lib/Test/Sandwich/Contexts/Kubernetes/Images.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++{-|++Functions for managing images on a Kubernetes cluster.++-}++module Test.Sandwich.Contexts.Kubernetes.Images (+  -- * Introduce a set of images+  introduceImages++  -- * Query images+  , getLoadedImages+  , getLoadedImages'++  , clusterContainsImage+  , clusterContainsImage'++  -- * Load images+  , loadImage+  , loadImage'++  -- * Load images if not present+  , loadImageIfNecessary+  , loadImageIfNecessary'++  -- * Retry helpers+  , withImageLoadRetry+  , withImageLoadRetry'++  -- * Util+  , findAllImages+  , findAllImages'++  -- * Types+  , kubernetesClusterImages+  , HasKubernetesClusterImagesContext++  , ImageLoadSpec(..)+  , ImagePullPolicy(..)+  ) where++import Control.Monad.Catch (Handler(..), MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.String.Interpolate+import Data.Text as T+import Relude+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.FindImages+import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster as Kind+import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images as Minikube+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.Images+++-- | Get the images loaded onto the cluster.+getLoadedImages :: (+  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 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.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.getLoadedImagesMinikube kubernetesClusterTypeMinikubeBinary kubernetesClusterName []++-- | Test if a cluster has a given image loaded.+clusterContainsImage :: (+  HasCallStack, KubernetesClusterBasic context m+  )+  -- | Image+  => Text+  -> m Bool+clusterContainsImage image = do+  kcc <- getContext kubernetesCluster+  clusterContainsImage' kcc image++-- | Same as 'clusterContainsImage', but allows you to pass in the 'KubernetesClusterContext'.+clusterContainsImage' :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m+  )+  -- | Cluster context+  => KubernetesClusterContext+  -- | Image+  -> Text+  -> m Bool+clusterContainsImage' kcc@(KubernetesClusterContext {kubernetesClusterType, kubernetesClusterName}) image = do+  case kubernetesClusterType of+    KubernetesClusterKind {..} ->+      Kind.clusterContainsImageKind kcc kubernetesClusterTypeKindClusterDriver kubernetesClusterTypeKindBinary kubernetesClusterTypeKindClusterEnvironment image+    KubernetesClusterMinikube {..} ->+      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 context m+  )+  -- | Image load spec+  => ImageLoadSpec+  -> m ()+loadImageIfNecessary image = do+  kcc <- getContext kubernetesCluster+  loadImageIfNecessary' kcc image++-- | Same as 'loadImage', but allows you to pass in the 'KubernetesClusterContext'.+loadImageIfNecessary' :: (+  HasCallStack, MonadFail m, KubernetesBasic context m+  )+  -- | Cluster context+  => KubernetesClusterContext+  -- | Image load spec+  -> ImageLoadSpec+  -- | The transformed image name+  -> m ()+loadImageIfNecessary' kcc imageLoadSpec = do+  unlessM (imageLoadSpecToImageName imageLoadSpec >>= clusterContainsImage' kcc) $+    void $ loadImage' kcc imageLoadSpec++-- | 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 context m+  )+  -- | Image load spec+  => ImageLoadSpec+  -- | The loaded image name+  -> m Text+loadImage image = do+  kcc <- getContext kubernetesCluster+  loadImage' kcc image++-- | Same as 'loadImage', but allows you to pass in the 'KubernetesClusterContext'.+loadImage' :: (+  HasCallStack, MonadFail m, KubernetesBasic context m+  )+  -- | Cluster context+  => KubernetesClusterContext+  -- | Image load spec+  -> ImageLoadSpec+  -- | The loaded image name+  -> m Text+loadImage' (KubernetesClusterContext {kubernetesClusterType, kubernetesClusterName}) imageLoadSpec = do+  debug [i|Loading container image '#{imageLoadSpec}'|]+  timeAction [i|Loading container image '#{imageLoadSpec}'|] $ do+    case kubernetesClusterType of+      (KubernetesClusterKind {..}) ->+        Kind.loadImageKind kubernetesClusterTypeKindBinary kubernetesClusterTypeKindClusterName imageLoadSpec kubernetesClusterTypeKindClusterEnvironment+      (KubernetesClusterMinikube {..}) ->+        -- Don't pass minikubeFlags; see comment above.+        Minikube.loadImageMinikube kubernetesClusterTypeMinikubeBinary kubernetesClusterName [] imageLoadSpec++        -- Because of the possible silent failure in "minikube image load", confirm that this+        -- image made it onto the cluster.+        -- At the moment this approach doesn't work, because if you do+        -- "minikube image load busybox:1.36.1-musl"+        -- followed by+        -- "minikube image ls",+        -- the result contains "docker.io/library/busybox:1.36.1-musl".+        -- Where did the docker.io/library/ come from? Need to understand this before we can+        -- check this properly.+        --+        -- image' <- Minikube.loadImage minikubeBinary kubernetesClusterName minikubeFlags image+        -- loadedImages <- Set.toList <$> getLoadedImages' kcc+        -- loadedImages `shouldContain` [image']+        -- return image'++-- | 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)++-- | 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+                                             warn [i|#{ils}: retrying load due to exception: #{e}|]+                                             return True)] $ \_ ->+    action+++-- | Introduce a list of images into a Kubernetes cluster.+-- Stores the list of transformed image names under the "kubernetesClusterImages" label.+introduceImages :: (+  HasCallStack, KubernetesClusterBasicWithoutReader 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)
+ lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++{-|++Install [Kata Containers](https://katacontainers.io) on a Kubernetes cluster.++-}++module Test.Sandwich.Contexts.Kubernetes.KataContainers (+  -- * Introduce Kata Containers+  introduceKataContainers++  -- * Bracket-style versions+  , withKataContainers+  , withKataContainers'++  -- * Types+  , KataContainersOptions(..)+  , SourceCheckout(..)+  , defaultKataContainersOptions++  , kataContainers+  , KataContainersContext(..)+  , HasKataContainersContext+  ) where++import Control.Lens+import Control.Monad+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Data.Aeson (FromJSON)+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Yaml as Yaml+import Kubernetes.OpenAPI.Model as Kubernetes+import Kubernetes.OpenAPI.ModelLens as Kubernetes+import Relude hiding (withFile)+import Safe+import System.Exit+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.FindImages+import Test.Sandwich.Contexts.Kubernetes.Images+import Test.Sandwich.Contexts.Kubernetes.Kubectl+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.Waits+import UnliftIO.Process+++data KataContainersContext = KataContainersContext {+  kataContainersOptions :: KataContainersOptions+  } deriving (Show)++data SourceCheckout =+  SourceCheckoutFilePath FilePath+  | SourceCheckoutNixDerivation Text+  deriving (Show, Eq)++data KataContainersOptions = KataContainersOptions {+  kataContainersSourceCheckout :: SourceCheckout+  -- | If set, this will overwrite the image in the DaemonSet in @kata-deploy.yaml@ and will set the 'ImagePullPolicy'+  -- to 'IfNotPresent'.+  -- This is useful because it's currently (8\/15\/2024) set to @quay.io\/kata-containers\/kata-deploy:latest@,+  -- with @imagePullPolicy: Always@. This is not reproducible and also doesn't allow us to cache images.+  , kataContainersKataDeployImage :: Maybe Text+  -- | Whether to pull the image using Docker and load it onto the cluster using 'loadImageIfNecessary''.+  , kataContainersPreloadImages :: Bool+  -- | Whether to label the node(s) with @katacontainers.io/kata-runtime=true@, since this seems not to happen+  -- automatically with kata-deploy.+  , kataContainersLabelNode :: Bool+  } deriving (Show)+defaultKataContainersOptions :: KataContainersOptions+defaultKataContainersOptions = KataContainersOptions {+  kataContainersSourceCheckout = SourceCheckoutNixDerivation kataContainersDerivation+  , kataContainersKataDeployImage = Just "quay.io/kata-containers/kata-deploy:3.9.0"+  , kataContainersPreloadImages = True+  , kataContainersLabelNode = True+  }++kataContainers :: Label "kataContainers" KataContainersContext+kataContainers = Label+type HasKataContainersContext context = HasLabel context "kataContainers" KataContainersContext++type ContextWithKataContainers context =+  LabelValue "kataContainers" KataContainersContext+  :> LabelValue "file-kubectl" (EnvironmentFile "kubectl")+  :> context++-- | Install Kata Containers on the cluster and introduce a 'KataContainersContext'.+introduceKataContainers :: (+  MonadMask m, Typeable context, KubernetesClusterBasicWithoutReader context m, HasNixContext context+  )+  -- | Options+  => KataContainersOptions+  -> SpecFree (ContextWithKataContainers context) m ()+  -> SpecFree context m ()+introduceKataContainers options = introduceBinaryViaNixPackage @"kubectl" "kubectl" . introduceWith "introduce KataContainers" kataContainers (void . withKataContainers options)++-- | Bracket-style version of 'introduceKataContainers'.+withKataContainers :: forall context m a. (+  HasCallStack, Typeable context, MonadFail m, MonadMask m, KubectlBasic context m+  )+  -- | Options+  => KataContainersOptions+  -> (KataContainersContext -> m a)+  -> m a+withKataContainers options action = do+  kcc <- getContext kubernetesCluster+  kubectlBinary <- askFile @"kubectl"+  withKataContainers' kcc kubectlBinary options action++-- | Same as 'withKataContainers', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path.+withKataContainers' :: forall context m a. (+  HasCallStack, Typeable context, MonadFail m, MonadMask m, KubernetesBasic context m+  )+  => KubernetesClusterContext+  -- | Path to @kubectl@ binary+  -> FilePath+  -> KataContainersOptions+  -> (KataContainersContext -> m a)+  -> m a+withKataContainers' kcc@(KubernetesClusterContext {..}) kubectlBinary options@(KataContainersOptions {..}) action = do+  -- Preflight checks+  case kubernetesClusterType of+    KubernetesClusterKind {} -> expectationFailure [i|Can't install Kata Containers on Kind at present.|]+    KubernetesClusterMinikube {..} -> do+      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 ()+        Nothing -> expectationFailure [i|Preflight check: couldn't parse output of minikube ssh "egrep -c 'vmx|svm' /proc/cpuinfo"|]++  -- Get Kata source dir+  kataRoot <- case kataContainersSourceCheckout of+    SourceCheckoutFilePath x -> pure x+    SourceCheckoutNixDerivation d -> getContextMaybe nixContext >>= \case+      Nothing -> expectationFailure [i|Wanted to build Kata Containers source checkout via derivation, but no Nix context was provided.|]+      Just nc -> buildNixCallPackageDerivation' nc d++  info [i|kataRoot: #{kataRoot}|]++  env <- askKubectlEnvironment kcc++  -- Now follow the instructions from+  -- https://github.com/kata-containers/kata-containers/blob/main/docs/install/minikube-installation-guide.md#installing-kata-containers++  -- Read the RBAC and DaemonSet configs+  rbacContents <- liftIO $ T.readFile $ kataRoot </> "tools/packaging/kata-deploy/kata-rbac/base/kata-rbac.yaml"+  deploymentContents' <- liftIO $ T.readFile $ kataRoot </> "tools/packaging/kata-deploy/kata-deploy/base/kata-deploy.yaml"+  let deploymentContents = case kataContainersKataDeployImage of+        Nothing -> deploymentContents'+        Just deployImage -> deploymentContents'+                          & setDaemonSetImage deployImage++  -- Preload any images+  when kataContainersPreloadImages $ do+    let images = findAllImages (rbacContents <> "\n---\n" <> deploymentContents)++    forM_ images $ \image -> do+      info [i|Preloading image: #{image}|]+      loadImageIfNecessary' kcc (ImageLoadSpecDocker image IfNotPresent)++  -- Install kata-deploy+  createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString rbacContents)+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)+  createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString deploymentContents)+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  podName <- waitUntil 600 $ do+    pods <- (T.words . toText) <$> readCreateProcessWithLogging ((+      (proc "kubectl" ["-n", "kube-system"+                      , "get", "pods", "-o=name"]) { env = Just env }+      ) { env = Just env }) ""++    case headMay [t | t <- pods, "pod/kata-deploy" `T.isPrefixOf` t] of+      Just x -> pure x+      Nothing -> expectationFailure [i|Couldn't find kata-deploy pod in: #{pods}|]++  info [i|Got podName: #{podName}|]++  -- Wait until the kata-deploy pod starts sleeping+  waitUntil 600 $ do+    (exitCode, sout, serr) <- readCreateProcessWithExitCode (+      (proc kubectlBinary ["-n", "kube-system"+                          , "exec", toString podName+                          , "--"+                          , "ps", "-ef"+                          ])+      { env = Just env }+      ) ""+    case exitCode of+      ExitSuccess -> return ()+      ExitFailure n -> expectationFailure [i|Command failed with code #{n}. Stderr: #{serr}|]++    toText sout `textShouldContain` "sleep infinity"++  -- Now install the runtime classes+  runtimeClassesContents <- liftIO $ T.readFile $ kataRoot </> "tools/packaging/kata-deploy/runtimeclasses/kata-runtimeClasses.yaml"+  createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString runtimeClassesContents)+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  -- Finally, label the node(s)+  when kataContainersLabelNode $ do+    createProcessWithLoggingAndStdin ((proc kubectlBinary ["label", "nodes", "--all", "--overwrite", "katacontainers.io/kata-runtime=true"]) { env = Just env }) (toString deploymentContents)+      >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  action $ KataContainersContext options++kataContainersDerivation = [__i|{fetchFromGitHub}:++                                fetchFromGitHub {+                                  owner = "kata-containers";+                                  repo = "kata-containers";+                                  rev = "cdaaf708a18da8e5f7e2b9824fa3e43b524893a5";+                                  sha256 = "sha256-aBcu59LybgZ9xkCDUzZXb60FeClQNG1ivfC6lWQdlb0=";+                                }+                               |]++setDaemonSetImage :: Text -> Text -> Text+setDaemonSetImage image = mconcat . fmap setDaemonSetImage' . T.splitOn "---\n"+  where+    setDaemonSetImage' :: Text -> Text+    setDaemonSetImage' (decode -> Right x@(V1DaemonSet {v1DaemonSetKind=(Just "DaemonSet")})) = x+      & set (v1DaemonSetSpecL . _Just . v1DaemonSetSpecTemplateL . v1PodTemplateSpecSpecL . _Just . v1PodSpecContainersL . ix 0 . v1ContainerImageL) (Just image)+      & set (v1DaemonSetSpecL . _Just . v1DaemonSetSpecTemplateL . v1PodTemplateSpecSpecL . _Just . v1PodSpecContainersL . ix 0 . v1ContainerImagePullPolicyL) (Just "IfNotPresent")+      & Yaml.encode+      & decodeUtf8+    setDaemonSetImage' t = t++decode :: FromJSON a => Text -> Either Yaml.ParseException a+decode = Yaml.decodeEither' . encodeUtf8
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++Create and manage Kubernetes clusters via [kind](https://kind.sigs.k8s.io/).++-}++module Test.Sandwich.Contexts.Kubernetes.KindCluster (+  introduceKindClusterViaNix+  , introduceKindClusterViaEnvironment+  , introduceKindCluster'++  -- * Bracket-style versions+  , withKindCluster+  , withKindCluster'++  -- * Image management+  -- | These are lower-level and Kind-specific; prefer working with the functions in "Test.Sandwich.Contexts.Kubernetes.Images".+  , Images.clusterContainsImageKind+  , Images.getLoadedImagesKind+  , Images.loadImageKind++  -- * Re-exported types+  , KubernetesClusterContext (..)+  , kubernetesCluster+  , HasKubernetesClusterContext++  -- * Types+  , KindClusterOptions (..)+  , defaultKindClusterOptions+  , KindClusterName(..)+  , ExtraPortMapping(..)+  , ExtraMount(..)+  , KindContext+  ) where++import Control.Monad+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.String.Interpolate+import qualified Data.Yaml as Yaml+import Kubernetes.Client.Config+import Relude+import System.IO.Temp+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.KindCluster.Config+import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster.Images as Images+import Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.Container (isInContainer)+import Test.Sandwich.Contexts.Kubernetes.Util.UUID+import Test.Sandwich.Contexts.Nix+import UnliftIO.Environment+import UnliftIO.Exception+import UnliftIO.Process+++-- Note: when using kind with podman as a driver, it's possible to run into a low PID limit+-- which isn't enough for all the processes in a Kubernetes cluster.+-- I debugged this and found a kind patch to fix it, described here:+-- https://github.com/kubernetes-sigs/kind/issues/3451#issuecomment-1855701939+--+-- You can also fix this at the podman level, with the following in `containers.conf`:+-- [containers]+-- pids_limit = 0+++data KindClusterName =+  -- | Give the kind cluster an exact name+  KindClusterNameExactly Text+  -- | Autogenerate the cluster name, with an optional fixed prefix+  | KindClusterNameAutogenerate (Maybe Text)+  deriving (Show, Eq)++data KindClusterOptions = KindClusterOptions {+  kindClusterNumNodes :: Int+  -- | Extra flags to pass to @kind@+  , kindClusterExtraFlags :: [Text]+  -- | Labels to apply to the created containers+  , kindClusterContainerLabels :: Map Text Text+  -- | Extra ports to map; see the [docs](https://kind.sigs.k8s.io/docs/user/configuration#extra-port-mappings)+  , kindClusterExtraPortMappings :: [ExtraPortMapping]+  -- | Extra mounts; see the [docs](https://kind.sigs.k8s.io/docs/user/configuration#extra-mounts)+  , kindClusterExtraMounts :: [ExtraMount]+  -- | Prefix for the generated cluster name+  , kindClusterName :: KindClusterName+  -- | Container driver, either "docker" or "podman". Defaults to "docker".+  , kindClusterDriver :: Maybe Text+  -- , kindClusterCpus :: Maybe Text+  -- , kindClusterMemory :: Maybe Text+  }+defaultKindClusterOptions :: KindClusterOptions+defaultKindClusterOptions = KindClusterOptions {+  kindClusterNumNodes = 3+  , kindClusterExtraFlags = []+  , kindClusterContainerLabels = mempty+  , kindClusterExtraPortMappings = []+  , kindClusterExtraMounts = []+  , kindClusterName = KindClusterNameAutogenerate Nothing+  , kindClusterDriver = Nothing+  -- , kindClusterCpus = Nothing+  -- , kindClusterMemory = Nothing+  }++-- * Introduce++-- | Alias to make type signatures shorter.+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@ and @kubectl@ binaries from the Nix context.+introduceKindClusterViaNix :: (+  HasBaseContext context, MonadUnliftIO m, MonadMask m, HasNixContext context+  )+  -- | Options+  => KindClusterOptions+  -- | Child spec+  -> SpecFree (KindContext context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceKindClusterViaNix kindClusterOptions spec =+  introduceBinaryViaNixPackage @"kind" "kind" $+    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@ and @kubectl@ binaries from the PATH.+introduceKindClusterViaEnvironment :: (+  HasBaseContext context, MonadMask m, MonadUnliftIO m+  )+  -- | Options+  => KindClusterOptions+  -> SpecFree (KindContext context) m ()+  -> 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@ 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 kubectlBinary kindClusterOptions spec =+  introduceFile @"kind" kindBinary $+    introduceFile @"kubectl" kubectlBinary $+    introduceWith "introduce kind cluster" kubernetesCluster (void . withKindCluster kindClusterOptions) $+      spec++-- * Implementation++-- | Bracket-style variant of 'introduceKindCluster''.+withKindCluster :: (+  MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m+  , HasBaseContextMonad context m, HasFile context "kind", HasFile context "kubectl"+  )+  -- | Options+  => KindClusterOptions+  -> (KubernetesClusterContext -> m a)+  -> m a+withKindCluster opts action = do+  kindBinary <- askFile @"kind"+  kubectlBinary <- askFile @"kubectl"+  withKindCluster' kindBinary kubectlBinary opts action++-- | 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 kubectlBinary opts@(KindClusterOptions {..}) action = do+  clusterName <- case kindClusterName of+    KindClusterNameExactly t -> pure t+    KindClusterNameAutogenerate maybePrefix -> do+      let prefix = fromMaybe "test-kind-cluster" maybePrefix+      clusterID <- makeUUID' 5+      return [i|#{prefix}-#{clusterID}|]++  kc <- isInContainer >>= \case+    False -> return $ kindConfig kindClusterNumNodes kindClusterContainerLabels kindClusterExtraPortMappings kindClusterExtraMounts+    True -> return $ kindConfig kindClusterNumNodes kindClusterContainerLabels kindClusterExtraPortMappings kindClusterExtraMounts++  Just dir <- getCurrentFolder+  kindConfigFile <- liftIO $ writeTempFile dir "kind-config" (decodeUtf8 $ Yaml.encode kc)+  info [i|kindConfigFile: #{kindConfigFile}|]++  kindKubeConfigFile <- liftIO $ writeTempFile dir "kind-kube-config" ""++  environmentToUse <- case kindClusterDriver of+    Just "docker" -> return Nothing+    Just "podman" -> do+      baseEnvironment <- getEnvironment+      return $ Just (("KIND_EXPERIMENTAL_PROVIDER", "podman") : baseEnvironment)+    Just x -> expectationFailure [i|Unexpected driver: #{x}|]+    Nothing -> return Nothing++  let driver = fromMaybe "docker" kindClusterDriver++  (bracket (startKindCluster kindBinary opts clusterName kindConfigFile kindKubeConfigFile environmentToUse driver)+           (\_ -> do+               ps <- createProcessWithLogging ((proc kindBinary ["delete", "cluster", "--name", toString clusterName]) {+                                                  env = environmentToUse+                                                  })+               void $ waitForProcess ps+           ))+           (\kcc -> bracket_ (setUpKindCluster kcc kindBinary kubectlBinary environmentToUse driver)+                             (return ())+                             (action kcc)+           )++startKindCluster :: (+  MonadLoggerIO m, MonadUnliftIO m+  ) => FilePath -> KindClusterOptions -> Text -> FilePath -> FilePath -> Maybe [(String, String)] -> Text -> m KubernetesClusterContext+startKindCluster kindBinary (KindClusterOptions {..}) clusterName kindConfigFile kindKubeConfigFile environmentToUse driver = do+  ps <- createProcessWithLogging ((proc kindBinary ["create", "cluster", "-v", "1", "--name", toString clusterName+                                                   , "--config", kindConfigFile+                                                   , "--kubeconfig", kindKubeConfigFile]) {+                                     delegate_ctlc = True+                                     , env = environmentToUse+                                     })+  void $ waitForProcess ps++  whenM isInContainer $+    callCommandWithLogging [i|#{kindBinary} get kubeconfig --internal --name #{clusterName} > "#{kindKubeConfigFile}"|]++  oidcCache <- newTVarIO mempty+  (m, c) <- liftIO $ mkKubeClientConfig oidcCache $ KubeConfigFile kindKubeConfigFile++  pure $ KubernetesClusterContext {+    kubernetesClusterName = toText clusterName+    , kubernetesClusterKubeConfigPath = kindKubeConfigFile+    , kubernetesClusterNumNodes = kindClusterNumNodes+    , kubernetesClusterClientConfig = (m, c)+    , kubernetesClusterType = KubernetesClusterKind kindBinary clusterName driver environmentToUse+    }
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Config.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.KindCluster.Config where++import Data.Aeson as A+import Data.Aeson.TH as A+import qualified Data.List as L+import Data.String.Interpolate+import qualified Data.Vector as V+import Relude+++data ExtraPortMapping = ExtraPortMapping {+  containerPort :: Int16+  , hostPort :: Int16++  -- | Set the bind address on the host+  -- 0.0.0.0 is the current default+  , listenAddress :: Maybe String++  -- | Set the protocol to one of TCP, UDP, SCTP.+  --  TCP is the default+  , protocol :: Maybe String+  }+deriveToJSON A.defaultOptions ''ExtraPortMapping++data ExtraMount = ExtraMount {+  hostPath :: String+  , containerPath :: String+  -- | If set, the mount is read-only.+  -- default false+  , readOnly :: Maybe Bool+  -- | If set, the mount needs SELinux relabeling.+  -- default false+  , selinuxRelabel :: Maybe Bool++  -- | Set propagation mode (None, HostToContainer or Bidirectional).+  -- See https://kubernetes.io/docs/concepts/storage/volumes/#mount-propagation.+  --+  -- WARNING: You very likely do not need this field.+  --+  -- This field controls propagation of *additional* mounts created+  -- at runtime underneath this mount.+  --+  -- On MacOS with Docker Desktop, if the mount is from macOS and not the+  -- docker desktop VM, you cannot use this field. You can use it for+  -- mounts to the linux VM.+  , propagation :: Maybe String+  }+deriveToJSON A.defaultOptions ''ExtraMount++kindConfig :: Int -> Map Text Text -> [ExtraPortMapping] -> [ExtraMount] -> A.Value+kindConfig numNodes _containerLabels extraPortMappings extraMounts = A.object [+  ("kind", A.String "Cluster")+  , ("apiVersion", A.String "kind.x-k8s.io/v1alpha4")+  , ("nodes", A.Array (V.fromList nodes))+  ]+  where+    nodes = mkNode "control-plane" : (L.replicate (numNodes - 1) (mkNode "worker"))++    mkNode :: Text -> A.Value+    mkNode role = A.object ([+      ("role", A.String role)+      ]+      <> if role == "control-plane" then [("kubeadmConfigPatches", A.Array (V.fromList [A.String extraPatches]))] else []+      <> if L.null extraPortMappings then [] else [("extraPortMappings", A.Array (V.fromList (fmap A.toJSON extraPortMappings)))]+      <> if L.null extraMounts then [] else [("extraMounts", A.Array (V.fromList (fmap A.toJSON extraMounts)))]+      )++    extraPatches = [__i|kind: InitConfiguration+                        nodeRegistration:+                          kubeletExtraArgs:+                            node-labels: "ingress-ready=true"+                            authorization-mode: "AlwaysAllow"+                            streaming-connection-idle-timeout: "0"+                       |]+++-- Note: here's how to provide an extra container registry:+-- containerdConfigPatches:+-- - |-+--   [plugins."io.containerd.grpc.v1.cri".registry.mirrors."#{registryHostname}:5000"]+--     endpoint = ["http://#{registryHostname}:5000"]
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.KindCluster.Images (+  getLoadedImagesKind+  , clusterContainsImageKind+  , loadImageKind+  ) 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 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.Images+import UnliftIO.Directory+import UnliftIO.Process+import UnliftIO.Temporary+++-- | Load an image into a Kind cluster.+loadImageKind :: (+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m+  )+  -- | Path to @kind@ binary+  => FilePath+  -- | Cluster name+  -> Text+  -- | Image load spec+  -> ImageLoadSpec+  -- | Extra environment variables+  -> Maybe [(String, String)]+  -- | Returns transformed image name+  -> m Text+loadImageKind kindBinary clusterName imageLoadSpec env = do+  case imageLoadSpec of+    ImageLoadSpecTarball image -> do+      doesDirectoryExist (toString image) >>= \case+        True ->+          -- Uncompressed directory: tar it up (but don't zip).+          -- TODO: don't depend on external tar binary+          withSystemTempDirectory "kind-image-zip" $ \dir -> do+            let tarFile = dir </> "test.tar"+            _ <- readCreateProcessWithLogging (shell [i|tar -C #{image} --dereference --hard-dereference --xform s:'^./':: -c . > #{tarFile}|]) ""+            imageLoad tarFile+            readUncompressedImageName (toString image)++        False -> case takeExtension (toString image) of+          ".tar" -> do+            imageLoad (toString image)+            readImageName (toString image)+          ".gz" -> do+            withSystemTempDirectory "image-tarball" $ \tempDir -> do+              let tarFile = tempDir </> "image.tar"+              -- TODO: don't depend on external gzip binary+              createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])+                >>= waitForProcess >>= (`shouldBe` ExitSuccess)+              imageLoad tarFile+              readImageName (toString image)+          _ -> expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]++    ImageLoadSpecDocker image pullPolicy -> do+      _ <- dockerPullIfNecessary image pullPolicy++      createProcessWithLogging (+        (shell [i|#{kindBinary} load docker-image #{image} --name #{clusterName}|]) {+            env = env+            }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)++      return image+    ImageLoadSpecPodman image pullPolicy -> do+      _ <- podmanPullIfNecessary image pullPolicy++      _ <- expectationFailure [i|Not implemented yet.|]++      return image+  where+    imageLoad tarFile =+      createProcessWithLogging (+        (shell [i|#{kindBinary} load image-archive #{tarFile} --name #{clusterName}|]) {+            env = env+            }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)++-- | Get the set of loaded images on the given Kind cluster.+getLoadedImagesKind :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m+  )+  => KubernetesClusterContext+  -- | Driver (should be "docker" or "podman")+  -> Text+  -- | Path to @kind@ binary+  -> FilePath+  -- | Extra environment variables+  -> Maybe [(String, String)]+  -> m (Set Text)+getLoadedImagesKind 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 _ = []++-- | Test if the Kind cluster contains a given image.+clusterContainsImageKind :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m+  )+  => KubernetesClusterContext+  -- | Driver (should be "docker" or "podman")+  -> Text+  -- | Path to @kind@ binary+  -> FilePath+  -- | Extra environment variables+  -> Maybe [(String, String)]+  -> Text+  -> m Bool+clusterContainsImageKind kcc driver kindBinary env image = do+  imageName <- case isAbsolute (toString image) of+    False -> pure image+    True -> readImageName (toString image)++  loadedImages <- getLoadedImagesKind kcc driver kindBinary env++  return (+    imageName `Set.member` loadedImages++    -- Deal with weird prefixing Minikube does; see+    -- https://github.com/kubernetes/minikube/issues/19343+    || ("docker.io/" <> imageName) `Set.member` loadedImages+    || ("docker.io/library/" <> imageName) `Set.member` loadedImages+    )
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Network.hs view
@@ -0,0 +1,15 @@++module Test.Sandwich.Contexts.Kubernetes.KindCluster.Network () where++-- linkContainer :: (MonadLoggerIO m, MonadCatch m) => Text -> m ()+-- linkContainer containerName = do+--   -- Connect the container to the "kind" network+--   ds <- getDockerState False+--   isConnectedToNetwork ds (Id containerName) "kind" >>= \case+--     Left err -> throw $ CodeDownException [i|Error checking if container '#{containerName}' is connected to network: '#{err}'|] (Just callStack)+--     Right True -> info [i|Container '#{containerName}' was already connected to "kind" network|]+--     Right False -> do+--       info [i|Connecting container '#{containerName}' to "kind" network|]+--       connectNetwork ds containerName "kind" >>= \case+--         Left err -> logError [i|Failed to link container #{containerName}: #{err}|]+--         Right () -> return ()
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardIngress (+  withForwardKubernetesService'+  ) where++import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import Data.String.Interpolate+import Data.Text as T+import qualified Data.Text.IO as T+import Network.Socket (PortNumber)+import Network.URI+import Relude hiding (withFile)+import Safe+import System.Exit+import System.FilePath+import qualified System.Random as R+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Util.Process+import Text.Regex.TDFA+import UnliftIO.Environment+import UnliftIO.Exception+import UnliftIO.IO (withFile)+import UnliftIO.Process+import UnliftIO.Temporary+import UnliftIO.Timeout+++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 kubernetesClusterTypeKindClusterEnvironment+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)++  randomHost <- generateRandomHostname++  withSystemTempDirectory "ingress.yaml" $ \dir -> do+    let configFile = dir </> "ingress.yaml"+    liftIO $ T.writeFile configFile (ingressConfig service randomHost)++    createProcessWithLogging ((proc kubectlBinary ["create"+                                                  , "--namespace", toString namespace+                                                  , "-f", configFile]) {+                                 env = Just env+                                 }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  -- TODO: wait for ingress to be ready?+  -- Possibly not necessary since the server context waits for 200 after this++  nodes <- ((T.words . toText) <$> (readCreateProcessWithLogging ((shell [i|kind get nodes --name "#{kubernetesClusterName}"|]) { env = Just env }) ""))+  controlPlaneNode <- case headMay [t | t <- nodes, "control-plane" `T.isInfixOf` t] of+    Nothing -> expectationFailure [i|Couldn't find control plane node (had: #{nodes})|]+    Just x -> pure x++  hostAndPort <- (T.strip . toText) <$> readCreateProcessWithLogging (+    proc (toString kubernetesClusterTypeKindClusterDriver) [+      "port", toString controlPlaneNode, "80/tcp"+      ]) ""+  let caddyArgs :: [String] = [+        "reverse-proxy"+        , "--from", "http://localhost:0"+        , "--to", "http://" <> toString hostAndPort+        , "--header-up", [i|Host: #{randomHost}|]+        ]++  info [i|caddy args: #{T.intercalate " " $ fmap toText caddyArgs}|]+  (stdoutRead, stdoutWrite) <- createPipe+  withFile "/dev/null" WriteMode $ \hNull -> do+    let cp = (proc "caddy" caddyArgs) {+          std_err = UseHandle stdoutWrite+          , std_out = UseHandle hNull+          , create_group = True+          }+    bracket (createProcess cp) (\(_, _, _, p) -> gracefullyStopProcess p 60_000_000) $ \_ -> do+      uriToUseMaybe <- timeout 60_000_000 $ fix $ \loop -> do+        line <- liftIO $ T.hGetLine stdoutRead+        debug [i|caddy: #{line}|]+        maybe loop pure (parsePort line)++      uriToUse <- case uriToUseMaybe of+        Nothing -> expectationFailure [i|Timed out waiting for caddy line with actual port|]+        Just x -> pure [i|http://localhost:#{x}|]+      info [i|uriToUse: #{uriToUse}|]++      action =<< case parseURI uriToUse of+        Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{uriToUse}|]+        Just x -> pure x++withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"+++ingressConfig :: Text -> Text -> Text+ingressConfig service host = [i|+apiVersion: networking.k8s.io/v1+kind: Ingress+metadata:+  name: #{service}-ingress+spec:+  rules:+  - host: #{host}+    http:+      paths:+      - path: /+        pathType: Prefix+        backend:+          service:+            name: #{service}+            port:+              number: 80+|]+++generateRandomHostname :: MonadIO m => m Text+generateRandomHostname = (toText <$>) $ liftIO $ do+  labelCount <- R.randomRIO (1, 5)+  labels <- replicateM labelCount (randomAlpha =<< R.randomRIO (5, 10))+  let hostname = L.intercalate "." labels+  return hostname+  where+    randomAlpha :: Int -> IO String+    randomAlpha len = do+      gen <- R.newStdGen+      return $ L.take len (R.randomRs ('a', 'z') gen)+++-- test :: Text+-- test = [i|"actual_address": "[::]:46763"|]++parsePort :: Text -> Maybe PortNumber+parsePort t = case t =~~ ([i|"actual_address":[[:space:]]*"\\[::\\]:([[:digit:]]+)"|] :: Text) of+  Just ((_before, _fullMatch, _after, [(readMay . toString) -> Just p]) :: (Text, Text, Text, [Text])) -> Just p+  _ -> Nothing
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardPortForward where++import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import Data.String.Interpolate+import Data.Text as T+import Network.URI+import Relude hiding (withFile)+import Safe+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.KubectlPortForward+import Test.Sandwich.Contexts.Kubernetes.Types+import UnliftIO.Environment+import UnliftIO.Process+++withForwardKubernetesService' :: (+  MonadUnliftIO m, MonadCatch m, MonadLoggerIO m+  , 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 kubernetesClusterTypeKindClusterEnvironment+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)++  portRaw <- (toString . T.strip . toText) <$> readCreateProcessWithLogging (+    (proc kubectlBinary [+      "get"+      , "service", toString service+      , "--namespace", toString namespace+      , [i|-o=jsonpath={.spec.ports[0].port}|]+      ]) { env = Just env }) ""++  port <- case readMay portRaw of+    Just p -> pure p+    Nothing -> expectationFailure [i|Failed to parse service port: #{portRaw}|]++  withKubectlPortForward' kubectlBinary kubernetesClusterKubeConfigPath namespace (const True) Nothing ("svc/" <> service) port $ \(KubectlPortForwardContext {..}) -> do+    action $ nullURI {+      uriScheme = "http:"+      , uriAuthority = Just (nullURIAuth {+                                uriRegName = "localhost"+                                , uriPort = ":" <> show kubectlPortForwardPort+                                })+      }++withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"
+ lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup (+  setUpKindCluster+  , getNodes+  ) where++import Control.Monad+import Control.Monad.Catch ( MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import qualified Data.Map as M+import Data.String.Interpolate+import Relude+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Waits+import UnliftIO.Environment+import UnliftIO.Process+++setUpKindCluster :: (+  MonadLoggerIO m, MonadUnliftIO m, MonadMask m+  ) => 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|#{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|#{kubectlBinary} wait pod+                         --namespace ingress-nginx+                         --for=condition=ready+                         --selector=app.kubernetes.io/component=controller+                         --timeout=300s|]+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  -- info [i|Installing metrics server using helm|]+  -- void $ runWithKubeConfig [i|helm repo add bitnami https://charts.bitnami.com/bitnami|]+  -- void $ runWithKubeConfig [i|helm install metrics-server-release bitnami/metrics-server|]++  info [i|Installing metrics server|]+  runWithKubeConfig [i|#{kubectlBinary} apply -f https://github.com/kubernetes-sigs/metrics-server/releases/download/v0.6.4/components.yaml|]+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)+  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 <- 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 }) ""))
+ lib/Test/Sandwich/Contexts/Kubernetes/Kubectl.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++{-|+Helper module for working with @kubectl@ processes.+-}++module Test.Sandwich.Contexts.Kubernetes.Kubectl (+  -- * Run commands with kubectl+  askKubectlArgs+  , askKubectlEnvironment+  ) where++import Control.Monad.Logger+import qualified Data.List as L+import Relude+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Types+import UnliftIO.Environment+++-- | Retrieve the @kubectl@ binary path and the set of environment variables to use when invoking it.+-- Derives these from a 'HasFile' context and the 'KubernetesClusterContext' respectively.+--+-- Useful for running Kubectl commands with 'System.Process.createProcess' etc.+askKubectlArgs :: (+  KubectlBasic context m+  )+  -- | Returns the @kubectl@ binary and environment variables.+  => m (FilePath, [(String, String)])+askKubectlArgs = do+  kcc <- getContext kubernetesCluster+  kubectlBinary <- askFile @"kubectl"+  (kubectlBinary, ) <$> askKubectlEnvironment kcc++-- | Same as 'askKubectlArgs', but only returns the environment variables.+askKubectlEnvironment :: (+  MonadLoggerIO m+  )+  -- | Kubernetes cluster context+  => KubernetesClusterContext+  -- | Returns the @kubectl@ environment variables.+  -> m [(String, String)]+askKubectlEnvironment (KubernetesClusterContext {..}) = do+  baseEnv <- getEnvironment+  return $ L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
+ lib/Test/Sandwich/Contexts/Kubernetes/KubectlLogs.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.Contexts.Kubernetes.KubectlLogs (+  withKubectlLogs+  , KubectlLogsContext (..)+  ) where++import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.String.Interpolate+import qualified Data.Text as T+import Relude hiding (withFile)+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Util.Process (gracefullyStopProcess)+import UnliftIO.Exception+import UnliftIO.IO (withFile)+import UnliftIO.Process+++-- * Types++data KubectlLogsContext = KubectlLogsContext {+  kubectlProcessHandle :: ProcessHandle+  }++-- * Implementation++-- | Run a @kubectl logs@ process, placing the logs in a file in the current test node directory.+--+-- Note that this will stop working if the pod you're talking to goes away (even if you do it against a service).+-- If this happens, a rerun of the command is needed to resume log forwarding.+withKubectlLogs :: (+  MonadLogger m, MonadFail m, MonadUnliftIO m+  , HasBaseContextMonad ctx m, HasFile ctx "kubectl"+  )+  -- | Kubeconfig file+  => FilePath+  -- | Namespace+  -> Text+  -- | Log target (pod, service, etc.)+  -> Text+  -- | Specific container to get logs from+  -> Maybe Text+  -- | Whether to interrupt the process to shut it down while cleaning up+  -> Bool+  -- | Callback receiving the 'KubectlLogsContext'+  -> (KubectlLogsContext -> m a)+  -> m a+withKubectlLogs kubeConfigFile namespace target maybeContainer interruptWhenDone action = do+  kubectlBinary <- askFile @"kubectl"++  let args = ["logs", toString target+             , "--namespace", toString namespace+             , "--kubeconfig", kubeConfigFile]+             <> (maybe [] (\x -> ["--container", toString x]) maybeContainer)++  Just dir <- getCurrentFolder+  let logPath = dir </> toString (T.replace "/" "_" target) <.> "log"++  debug [i|Running kubectl #{unwords $ fmap toText args} --> #{logPath}|]++  withFile logPath WriteMode $ \h -> do+    hSetBuffering h LineBuffering++    bracket (createProcess ((proc kubectlBinary args) {+                               std_out = UseHandle h+                               , std_err = UseHandle h+                               , create_group = True+                               }))+            (\(_, _, _, ps) -> if+                | interruptWhenDone -> void $ gracefullyStopProcess ps 30_000_000+                | otherwise -> void $ waitForProcess ps+            )+            (\(_, _, _, ps) -> do+                action $ KubectlLogsContext ps+            )
+ lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.Contexts.Kubernetes.KubectlPortForward (+  withKubectlPortForward+  , withKubectlPortForward'+  , KubectlPortForwardContext (..)+  ) where++import Control.Monad+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Unlift+import Control.Retry+import Data.String.Interpolate+import qualified Data.Text as T+import Network.Socket (PortNumber)+import Relude hiding (withFile)+import System.FilePath+import System.Process (getPid)+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.Ports+import Test.Sandwich.Contexts.Kubernetes.Util.SocketUtil+import Test.Sandwich.Util.Process (gracefullyStopProcess)+import UnliftIO.Async+import UnliftIO.Directory+import UnliftIO.Exception+import UnliftIO.IO+import UnliftIO.Process+++-- * Types++newtype KubectlPortForwardContext = KubectlPortForwardContext {+  kubectlPortForwardPort :: PortNumber+  }++-- * Implementation++-- | Run a @kubectl port-forward@ process, making the port available in the 'KubectlPortForwardContext'.+--+-- Note that this will stop working if the pod you're talking to goes away (even if you do it against a service).+-- If this happens, a rerun of the command is needed to resume port forwarding.+withKubectlPortForward :: (+  HasCallStack, MonadCatch m, KubectlBasic context m+  )+  -- | Path to kubeconfig file+  => FilePath+  -- | Namespace+  -> Text+  -- | Target name (pod, service, etc.)+  -> Text+  -- | Target port number+  -> PortNumber+  -> (KubectlPortForwardContext -> m a)+  -> m a+withKubectlPortForward kubeConfigFile namespace targetName targetPort action = do+  kubectlBinary <- askFile @"kubectl"+  withKubectlPortForward' kubectlBinary kubeConfigFile namespace (const True) Nothing targetName targetPort action++-- | Same as 'withKubectlPortForward', but allows you to pass in the @kubectl@ binary path.+withKubectlPortForward' :: (+  HasCallStack, MonadCatch m, KubernetesBasic context m+  )+  => FilePath+  -- | Path to kubeconfig file+  -> FilePath+  -- | Namespace+  -> Text+  -- | Callback to check if the proposed local port is acceptable+  -> (PortNumber -> Bool)+  -> Maybe PortNumber+  -- | Target name (pod, service, etc.)+  -> Text+  -- | Target port number+  -> PortNumber+  -> (KubectlPortForwardContext -> m a)+  -> m a+withKubectlPortForward' kubectlBinary kubeConfigFile namespace isAcceptablePort maybeHostPort targetName targetPort action = do+  port <- maybe (findFreePortOrException' isAcceptablePort) return maybeHostPort++  let args = ["port-forward", toString targetName, [i|#{port}:#{targetPort}|]+             , "--namespace", toString namespace+             , "--kubeconfig", kubeConfigFile]++  debug [i|Running kubectl #{unwords $ fmap toText args}|]++  dir <- getCurrentFolder >>= \case+    Just x -> pure (x </> "port-forwarding-logs-kubectl")+    Nothing -> expectationFailure [i|Expected a current folder in withKubectlPortForward'|]++  createDirectoryIfMissing True dir+  let logPath = dir </> toString (T.replace "/" "_" targetName) <.> "port-forwarding.log"++  withFile logPath WriteMode $ \h -> do++    let restarterThread = forever $ do+          bracket (createProcess ((proc kubectlBinary args) {+                                     std_out = UseHandle h+                                     , std_err = UseHandle h+                                     , create_group = True+                                     }))+                  (\(_, _, _, ps) -> gracefullyStopProcess ps 30000000)+                  (\(_, _, _, ps) -> do+                      pid <- liftIO $ getPid ps+                      info [i|Got pid for kubectl port forward: #{pid}|]++                      code <- waitForProcess ps+                      warn [i|kubectl port-forward #{targetName} #{port}:#{targetPort} exited with code: #{code}. Restarting...|]+                  )++    withAsync restarterThread $ \_ -> do+      let policy = constantDelay 100000 <> limitRetries 100+      void $ liftIO $ retrying policy (\_ ret -> return ret) $ \_ -> do+        not <$> isPortOpen (simpleSockAddr (127, 0, 0, 1) port)++      action $ KubectlPortForwardContext { kubectlPortForwardPort = port }
+ lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++module Test.Sandwich.Contexts.Kubernetes.Longhorn (+  introduceLonghorn+  , withLonghorn+  , withLonghorn'++  , LonghornOptions(..)+  , defaultLonghornOptions++  , longhorn+  , LonghornContext(..)+  , HasLonghornContext+  ) where++import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import Relude hiding (withFile)+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Nix+import UnliftIO.Environment+import UnliftIO.Process++-- | Unfortunately it seems Longhorn isn't going to work on container-based Kubernetes contexts like+-- Minikube or Kind: https://github.com\/longhorn\/longhorn\/discussions\/2702+--+-- So, this module is dead for now.+++data LonghornContext = LonghornContext {+  longhornOptions :: LonghornOptions+  } deriving (Show)++data LonghornOptions = LonghornOptions {+  longhornYaml :: String+  } deriving (Show)+defaultLonghornOptions :: LonghornOptions+defaultLonghornOptions = LonghornOptions {+  longhornYaml = "https://raw.githubusercontent.com/longhorn/longhorn/v1.6.2/deploy/longhorn.yaml"+  }++longhorn :: Label "longhorn" LonghornContext+longhorn = Label+type HasLonghornContext context = HasLabel context "longhorn" LonghornContext++introduceLonghorn :: (+  HasBaseContext context, HasKubernetesClusterContext context, MonadUnliftIO m, HasNixContext context+  ) => LonghornOptions -> SpecFree (LabelValue "longhorn" LonghornContext :> LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context) m () -> SpecFree context m ()+introduceLonghorn options =+  introduceBinaryViaNixPackage @"kubectl" "kubectl"+  . introduceWith "introduce Longhorn" longhorn (void . withLonghorn options)++withLonghorn :: forall context m a. (+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m+  , HasBaseContextMonad context m, HasKubernetesClusterContext context, HasFile context "kubectl"+  ) => LonghornOptions -> (LonghornContext -> m a) -> m a+withLonghorn options action = do+  kcc <- getContext kubernetesCluster+  kubectlBinary <- askFile @"kubectl"+  withLonghorn' kcc kubectlBinary options action++withLonghorn' :: forall m a. (+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m+  ) => KubernetesClusterContext -> String -> LonghornOptions -> (LonghornContext -> m a) -> m a+withLonghorn' (KubernetesClusterContext {kubernetesClusterKubeConfigPath}) kubectlBinary options@(LonghornOptions {..}) action = do+  baseEnv <- getEnvironment+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)++  createProcessWithLogging ((proc kubectlBinary ["apply", "-f", longhornYaml]) { env = Just env })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  action $ LonghornContext options
+ lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++Create and manage Kubernetes clusters via [Minikube](https://minikube.sigs.k8s.io).++-}++module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster (+  -- * Introducing a cluster via Minikube+  introduceMinikubeClusterViaNix+  , introduceMinikubeClusterViaEnvironment+  , introduceMinikubeCluster'++  -- * Bracket-style functions+  , withMinikubeCluster+  , withMinikubeCluster'+  , withMinikubeCluster''++  -- * Image management+  -- | These are lower-level and Minikube-specific; prefer working with the functions in "Test.Sandwich.Contexts.Kubernetes.Images".+  , Images.clusterContainsImageMinikube+  , Images.getLoadedImagesMinikube+  , Images.loadImageMinikube++  -- * Re-exported cluster types+  , kubernetesCluster+  , KubernetesClusterContext (..)+  , HasKubernetesClusterContext++  -- * Types+  , MinikubeClusterOptions (..)+  , defaultMinikubeClusterOptions+  ) where++import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import Data.String.Interpolate+import Data.Text as T+import Kubernetes.Client.Config+import Relude hiding (withFile)+import System.Exit+import System.FilePath+import System.IO.Temp+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images as Images+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.UUID+import Test.Sandwich.Contexts.Nix+import UnliftIO.Environment+import UnliftIO.Exception+import UnliftIO.IO+import UnliftIO.Process+++data MinikubeClusterOptions = MinikubeClusterOptions {+  minikubeClusterNumNodes :: Int+  , minikubeClusterExtraFlags :: [Text]+  , minikubeClusterNamePrefix :: Maybe Text+  , minikubeClusterDriver :: Maybe Text+  , minikubeClusterCpus :: Maybe Text+  , minikubeClusterMemory :: Maybe Text+  }+defaultMinikubeClusterOptions :: MinikubeClusterOptions+defaultMinikubeClusterOptions = MinikubeClusterOptions {+  minikubeClusterNumNodes = 3+  , minikubeClusterExtraFlags = []+  , minikubeClusterNamePrefix = Nothing+  , minikubeClusterDriver = Nothing+  , minikubeClusterCpus = Nothing+  , minikubeClusterMemory = Nothing+  }++-- * Introduce++type MinikubeClusterContext context =+  LabelValue "kubernetesCluster" KubernetesClusterContext+  :> LabelValue "file-minikube" (EnvironmentFile "minikube")+  :> context++-- | Introduce a Minikube cluster, deriving the @minikube@ binary from the Nix context.+introduceMinikubeClusterViaNix :: (+  HasBaseContext context, MonadUnliftIO m, HasNixContext context+  )+  -- | Options+  => MinikubeClusterOptions+  -- | Child spec+  -> SpecFree (MinikubeClusterContext context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceMinikubeClusterViaNix minikubeClusterOptions spec =+  introduceBinaryViaNixPackage @"minikube" "minikube" $+    introduceWith "introduce minikube cluster" kubernetesCluster (void . withMinikubeCluster minikubeClusterOptions) spec++-- | Introduce a Minikube cluster, deriving the @minikube@ binary from the PATH.+introduceMinikubeClusterViaEnvironment :: (+  HasBaseContext context, MonadUnliftIO m+  )+  -- | Options+  => MinikubeClusterOptions+  -> SpecFree (MinikubeClusterContext context) m ()+  -> SpecFree context m ()+introduceMinikubeClusterViaEnvironment minikubeClusterOptions spec =+  introduceBinaryViaEnvironment @"minikube" $+    introduceWith "introduce minikube cluster" kubernetesCluster (void . withMinikubeCluster minikubeClusterOptions) spec++-- | Introduce a Minikube cluster, passing in the @minikube@ binary path.+introduceMinikubeCluster' :: (+  HasBaseContext context, MonadUnliftIO m+  )+  -- | Path to @minikube@ binary+  => FilePath+  -> MinikubeClusterOptions+  -> SpecFree (MinikubeClusterContext context) m ()+  -> SpecFree context m ()+introduceMinikubeCluster' minikubeBinary minikubeClusterOptions spec =+  introduceFile @"minikube" minikubeBinary $+    introduceWith "introduce minikube cluster" kubernetesCluster (void . withMinikubeCluster minikubeClusterOptions) $+      spec++-- * Implementation++-- | Bracket-style variant for introducing a Minikube cluster, using a @HasFile context "minikube"@ constraint.+withMinikubeCluster :: (+  HasBaseContextMonad context m, HasFile context "minikube"+  , MonadLoggerIO m, MonadUnliftIO m, MonadFail m+  )+  -- | Options+  => MinikubeClusterOptions+  -> (KubernetesClusterContext -> m a)+  -> m a+withMinikubeCluster options action = do+  minikubeBinary <- askFile @"minikube"+  withMinikubeCluster' minikubeBinary options action++-- | Same as 'withMinikubeCluster', but allows you to pass the path to the @minikube@ binary.+withMinikubeCluster' :: (+  HasBaseContextMonad context m+  , MonadLoggerIO m, MonadUnliftIO m, MonadFail m+  )+  -- | Path to @minikube@ binary+  => FilePath+  -> MinikubeClusterOptions+  -> (KubernetesClusterContext -> m a)+  -> m a+withMinikubeCluster' minikubeBinary options@(MinikubeClusterOptions {..}) action = do+  let prefix = fromMaybe "test-minikube-cluster" minikubeClusterNamePrefix+  clusterID <- makeUUID' 5+  let clusterName = [i|#{prefix}-#{clusterID}|]+  withMinikubeCluster'' clusterName minikubeBinary options action++-- | Same as 'withMinikubeCluster'', but allows you to pass the cluster name.+withMinikubeCluster'' :: (+  HasBaseContextMonad context m+  , MonadLoggerIO m, MonadUnliftIO m, MonadFail m+  )+  -- | Cluster name+  => String+  -> FilePath+  -> MinikubeClusterOptions+  -> (KubernetesClusterContext -> m a)+  -> m a+withMinikubeCluster'' clusterName minikubeBinary options@(MinikubeClusterOptions {..}) action = do+  Just dir <- getCurrentFolder++  minikubeDir <- liftIO $ createTempDirectory dir "minikube"++  let minikubeKubeConfigFile = minikubeDir </> "minikube-config"+  writeFile minikubeKubeConfigFile ""++  let startLogFile = minikubeDir </> "minikube-start.log"+  let deleteLogFile = minikubeDir </> "minikube-delete.log"++  withFile startLogFile WriteMode $ \logH ->+    (bracket (startMinikubeCluster minikubeBinary logH clusterName minikubeKubeConfigFile options)+             (\_ -> do+                 info [i|Deleting minikube cluster: #{clusterName}|]++                 let extraFlags = case "--rootless" `L.elem` minikubeClusterExtraFlags of+                       True -> ["--rootless"]+                       False -> []++                 withFile deleteLogFile WriteMode $ \deleteH -> do+                   let deleteCp = (proc minikubeBinary (["delete"+                                                        , "--profile", clusterName+                                                        , "--logtostderr"+                                                        ] <> extraFlags)) {+                         delegate_ctlc = True+                         , create_group = True+                         , std_out = UseHandle deleteH+                         , std_err = UseHandle deleteH+                         }+                   withCreateProcess deleteCp $ \_ _ _ p ->+                     waitForProcess p >>= \case+                       ExitSuccess -> return ()+                       ExitFailure n -> warn [i|Minikube cluster delete failed with code #{n}.|]+             ))+             (\p -> do+                 waitForProcess p >>= \case+                   ExitSuccess -> return ()+                   ExitFailure n -> expectationFailure [i|Minikube cluster creation failed with code #{n}.|]++                 oidcCache <- newTVarIO mempty+                 (m, c) <- liftIO $ mkKubeClientConfig oidcCache $ KubeConfigFile minikubeKubeConfigFile++                 action $ KubernetesClusterContext {+                   kubernetesClusterName = toText clusterName+                   , kubernetesClusterKubeConfigPath = minikubeKubeConfigFile+                   , kubernetesClusterNumNodes = minikubeClusterNumNodes+                   , kubernetesClusterClientConfig = (m, c)+                   , kubernetesClusterType = KubernetesClusterMinikube {+                       kubernetesClusterTypeMinikubeBinary = minikubeBinary+                       , kubernetesClusterTypeMinikubeProfileName = toText clusterName+                       , kubernetesClusterTypeMinikubeFlags = minikubeClusterExtraFlags+                       }+                   }+             )++startMinikubeCluster :: (+  MonadLoggerIO m+  ) => FilePath -> Handle -> String -> String -> MinikubeClusterOptions -> m ProcessHandle+startMinikubeCluster minikubeBinary logH clusterName minikubeKubeConfigFile (MinikubeClusterOptions {..}) = do+  baseEnv <- getEnvironment+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", minikubeKubeConfigFile) : baseEnv)++  -- Note: this doesn't actually work! These options actually go to the docker daemon, not the "start" operation.+  -- It may not be possible to get a label on the Docker container in current minikube.+  -- let labelArgs = case dockerLabels of+  --       x | M.null x -> []+  --       xs -> "--docker-opt" : [[i|label=#{k}=#{v}|] | (k, v) <- M.toList xs]++  let driverAndResourceFlags = case minikubeClusterDriver of+        Nothing -> ["--driver=docker"+                   , [i|--memory=#{fromMaybe "16000mb" minikubeClusterMemory}|]+                   , [i|--cpus=#{fromMaybe "max" minikubeClusterCpus}|]+                   ]+        Just d -> [[i|--driver=#{d}|]+                  , [i|--memory=#{fromMaybe "16000mb" minikubeClusterMemory}|]+                  , [i|--cpus=#{fromMaybe "8" minikubeClusterCpus}|]+                  ]++  let args = ["start"+             , "--profile", clusterName+             , "--logtostderr"+             -- , "--addons=ingress"+             , "--extra-config=kubelet.streaming-connection-idle-timeout=5h"+             ]+             <> driverAndResourceFlags+             <> (fmap toString minikubeClusterExtraFlags)++  info [i|export KUBECONFIG='#{minikubeKubeConfigFile}'|]+  debug [i|Starting minikube with args: #{minikubeBinary} #{T.unwords $ fmap toText args}|]++  (_, _, _, p) <- createProcess (+    (proc minikubeBinary args) {+        delegate_ctlc = True+        , create_group = True+        , env = Just env+        , std_out = UseHandle logH+        , std_err = UseHandle logH+        })+  return p++-- Debugging (in case of certificate issues such as https://github.com/channable/vaultenv/issues/99)+-- import Kubernetes.Client.Auth.OIDC+-- oidcCache :: OIDCCache <- Relude.newTVarIO mempty+-- (m, c) <- mkKubeClientConfig oidcCache $ KubeConfigFile "/tmp/test-minikube-cluster-config-e695417a5bf81acf/minikube-kube-config"+-- import Kubernetes.OpenAPI.Core+-- import Kubernetes.OpenAPI.API.AppsV1 as Kubernetes+-- import Kubernetes.OpenAPI.API.BatchV1 as Kubernetes+-- import Kubernetes.OpenAPI.API.CoreV1 as Kubernetes+-- import Kubernetes.OpenAPI.Core as Kubernetes+-- import Kubernetes.OpenAPI.MimeTypes+-- import Kubernetes.OpenAPI.Model as Kubernetes+-- import Kubernetes.OpenAPI.Client as Kubernetes+-- MimeResult parsedResult _httpResponse <- liftIO (dispatchMime m c (listNamespacedPod (Accept MimeJSON) (Namespace "default")))
+ lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Forwards where++import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import Data.String.Interpolate+import Data.Text as T+import Network.URI+import Relude hiding (withFile)+import System.IO (hGetLine)+import System.Process (getPid)+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Util.Process+import UnliftIO.Async+import UnliftIO.Environment+import UnliftIO.Exception+import UnliftIO.Process+++withForwardKubernetesService' :: (+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m+  ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a+withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) profile namespace service action = do+  baseEnv <- liftIO getEnvironment+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)++  let extraFlags = case "--rootless" `L.elem` kubernetesClusterTypeMinikubeFlags of+        True -> ["--rootless"]+        False -> []++  let args = extraFlags <> [+        "--profile", toString profile+        , "--namespace", toString namespace+        , "--logtostderr"+        , "service"+        , toString service+        , "--url"]+  info [i|#{kubernetesClusterTypeMinikubeBinary} #{T.unwords $ fmap toText args}|]++  (stdoutRead, stdoutWrite) <- liftIO createPipe+  (stderrRead, stderrWrite) <- liftIO createPipe++  let forwardStderr = forever $ do+        line <- liftIO $ hGetLine stderrRead+        info [i|minikube service stderr: #{line}|]++  withAsync forwardStderr $ \_ -> do+    let cp = (proc kubernetesClusterTypeMinikubeBinary args) {+          env = Just env+          , std_out = UseHandle stdoutWrite+          , std_err = UseHandle stderrWrite+          , create_group = True+          }++    let stop (_, _, _, p) = liftIO (getPid p) >>= \case+          Nothing -> return ()+          Just _pid -> gracefullyStopProcess p 120_000_000++    bracket (createProcess cp) stop $ \_ -> do+      raw <- liftIO $ hGetLine stdoutRead++      info [i|withForwardKubernetesService': (#{namespace}) #{service} -> #{raw}|]++      action =<< case parseURI (toString (T.strip (toText raw))) of+        Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{raw}|]+        Just x -> pure x++withForwardKubernetesService' _ _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"
+ lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images (+  getLoadedImagesMinikube+  , clusterContainsImageMinikube+  , loadImageMinikube+  ) where++import Control.Monad+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.List as L+import qualified Data.Set as Set+import Data.String.Interpolate+import Data.Text as T+import Relude+import System.Exit+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.Images+import Text.Regex.TDFA+import UnliftIO.Directory+import UnliftIO.Process+import UnliftIO.Temporary+++-- | Load an image onto a cluster. This image can come from a variety of sources, as specified by the 'ImageLoadSpec'.+loadImageMinikube :: (+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m+  )+  -- | Path to @minikube@ binary+  => FilePath+  -- | Cluster name+  -> Text+  -- | Extra flags to pass to @minikube@+  -> [Text]+  -- | Image load spec+  -> ImageLoadSpec+  -- | Returns transformed image name+  -> m Text+loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do+  case imageLoadSpec of+    ImageLoadSpecTarball image -> do+      -- File or directory image+      doesDirectoryExist (toString image) >>= \case+        True ->+          -- Uncompressed directory: tar it up (but don't zip).+          -- Formerly we would execute a shell with a pipe to direct the tar output directly into "minikube image load".+          -- But then "minikube image load" would just write its own tarball in /tmp, like /tmp/build.12345.tar, and+          -- leave it there!+          withSystemTempDirectory "image-tarball" $ \tempDir -> do+            let tarFile = tempDir </> "image.tar"+            -- TODO: don't depend on external tar file+            createProcessWithLogging (shell [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c . > "#{tarFile}"|])+              >>= waitForProcess >>= (`shouldBe` ExitSuccess)+            imageLoad tarFile False+            readImageName (toString image)+        False -> case takeExtension (toString image) of+          ".tar" -> do+            imageLoad (toString image) False+            readImageName (toString image)+          ".gz" -> do+            withSystemTempDirectory "image-tarball" $ \tempDir -> do+              let tarFile = tempDir </> "image.tar"+              -- TODO: don't depend on external gzip file+              createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])+                >>= waitForProcess >>= (`shouldBe` ExitSuccess)+              imageLoad tarFile False+              readImageName (toString image)+          _ -> expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]++    ImageLoadSpecDocker image pullPolicy -> do+      _ <- dockerPullIfNecessary image pullPolicy+      imageLoad (toString image) True >> return image++    ImageLoadSpecPodman image pullPolicy -> do+      _ <- podmanPullIfNecessary image pullPolicy+      imageLoad (toString image) True >> return image++  where+    imageLoad :: (MonadLoggerIO m, HasCallStack) => String -> Bool -> m ()+    imageLoad toLoad daemon = do+      let extraFlags = case "--rootless" `L.elem` minikubeFlags of+                         True -> ["--rootless"]+                         False -> []++      let args = ["image", "load", toLoad+                 , "--profile", toString clusterName+                 , "--logtostderr=true", "--v=1"+                 , [i|--daemon=#{A.encode daemon}|]+                 ] <> extraFlags++      debug [i|#{minikubeBinary} #{T.unwords $ fmap toText args}|]++      -- Gather stderr output while also logging it+      logFn <- askLoggerIO+      stderrOutputVar <- newIORef mempty+      let customLogFn loc src level str = do+            modifyIORef' stderrOutputVar (<> str)+            logFn loc src level str++      liftIO $ flip runLoggingT customLogFn $+        createProcessWithLogging (proc minikubeBinary args)+          >>= waitForProcess >>= (`shouldBe` ExitSuccess)++      stderrOutput <- fromLogStr <$> readIORef stderrOutputVar++      let ef (details :: Text) = expectationFailure [i|minikube image load failed; error output detected (#{details})|]++      when (check1 stderrOutput) $ ef "Contained 'Failed to load cached images for profile' message"+      when (check2 stderrOutput) $ ef "Contained 'ctr: failed to ingest' message"+      when (check3 stderrOutput) $ ef "Contained 'failed pushing to' message"++    -- This is crazy, but minikube image load sometimes fails silently.+    -- One example: https://github.com/kubernetes/minikube/issues/16032+    -- As a result, we add a few checks to detect the cases we've seen that represent a failed load.++    check1 bytes = "Failed to load cached images for profile" `B.isInfixOf` bytes+                 && "make sure the profile is running." `B.isInfixOf` bytes++    check2 bytes = "ctr: failed to ingest" `B.isInfixOf` bytes+                 && "failed to copy: failed to send write: error reading from server: EOF: unavailable" `B.isInfixOf` bytes++    check3 :: ByteString -> Bool+    check3 bytes = bytes =~ ("failed pushing to:[[:blank:]]*[^[:space:]]+$" :: Text)++-- | Get the loaded images on a cluster, by cluster name.+getLoadedImagesMinikube :: (+  MonadUnliftIO m, MonadLogger m+  )+  -- | Path to @minikube@ binary+  => FilePath+  -- | Cluster name+  -> Text+  -- | Extra flags to pass to @minikube@+  -> [Text]+  -> m (Set Text)+getLoadedImagesMinikube 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)) ""++-- | Test if the cluster contains a given image, by cluster name.+clusterContainsImageMinikube :: (+  MonadUnliftIO m, MonadLogger m+  )+  -- | Path to @minikube@ binary+  => FilePath+  -- | Cluster name+  -> Text+  -- | Extra flags to pass to @minikube@+  -> [Text]+  -- | Image name+  -> Text+  -> m Bool+clusterContainsImageMinikube minikubeBinary clusterName minikubeFlags image = do+  imageName <- case isAbsolute (toString image) of+    False -> pure image+    True -> readImageName (toString image)++  loadedImages <- getLoadedImagesMinikube minikubeBinary clusterName minikubeFlags++  return (+    imageName `Set.member` loadedImages++    -- Deal with weird prefixing Minikube does; see+    -- https://github.com/kubernetes/minikube/issues/19343+    || ("docker.io/" <> imageName) `Set.member` loadedImages+    || ("docker.io/library/" <> imageName) `Set.member` loadedImages+    )
+ lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++Install the [MinIO Kubernetes operator](https://min.io/docs/minio/kubernetes/upstream/operations/installation.html) onto a Kubernetes cluster.++This is necessary if you want to use the "Test.Sandwich.Contexts.Kubernetes.MinioS3Server" module to create actual S3 servers.++-}++module Test.Sandwich.Contexts.Kubernetes.MinioOperator (+  introduceMinioOperator+  , introduceMinioOperator'++  -- * Bracket-style variants+  , withMinioOperator+  , withMinioOperator'++  -- * Types+  , minioOperator+  , MinioOperatorContext(..)+  , MinioOperatorOptions(..)+  , defaultMinioOperatorOptions+  , HasMinioOperatorContext+  ) where++import Control.Monad+import Control.Monad.IO.Unlift+import Data.Aeson (FromJSON)+import Data.String.Interpolate+import Data.Text as T+import qualified Data.Yaml as Yaml+import Kubernetes.OpenAPI.Model as Kubernetes+import Relude+import Safe+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.FindImages+import Test.Sandwich.Contexts.Kubernetes.Images+import Test.Sandwich.Contexts.Kubernetes.Kubectl+import Test.Sandwich.Contexts.Kubernetes.Types+import UnliftIO.Exception+import UnliftIO.Process+++data MinioOperatorContext = MinioOperatorContext+  deriving (Show)++minioOperator :: Label "minioOperator" MinioOperatorContext+minioOperator = Label+type HasMinioOperatorContext context = HasLabel context "minioOperator" MinioOperatorContext++data MinioOperatorOptions = MinioOperatorOptions {+  minioOperatorPreloadImages :: Bool+  }+defaultMinioOperatorOptions :: MinioOperatorOptions+defaultMinioOperatorOptions = MinioOperatorOptions {+  minioOperatorPreloadImages = True+  }++-- | Install the [MinIO Kubernetes operator](https://min.io/docs/minio/kubernetes/upstream/operations/installation.html) onto a Kubernetes cluster.+introduceMinioOperator :: (+  KubectlBasicWithoutReader context m+  )+  -- | Options+  => MinioOperatorOptions+  -> SpecFree (LabelValue "minioOperator" MinioOperatorContext :> context) m ()+  -> SpecFree context m ()+introduceMinioOperator options = introduceWith "introduce MinIO operator" minioOperator $ \action -> do+  kcc <- getContext kubernetesCluster+  void $ withMinioOperator options kcc action++-- | Same as 'introduceMinioOperator', but allows you to pass in the @kubectl@ binary path.+introduceMinioOperator' :: (+  HasCallStack, MonadFail m, MonadUnliftIO m, HasKubernetesClusterContext context, HasBaseContext context+  )+  -- | Path to @kubectl@ binary+  => FilePath+  -- | Options+  -> MinioOperatorOptions+  -> SpecFree (LabelValue "minioOperator" MinioOperatorContext :> context) m ()+  -> SpecFree context m ()+introduceMinioOperator' kubectlBinary options = introduceWith "introduce MinIO operator" minioOperator $ \action -> do+  kcc <- getContext kubernetesCluster+  void $ withMinioOperator' kubectlBinary options kcc action++-- | Bracket-style variant of 'introduceMinioOperator'.+withMinioOperator :: (+  HasCallStack, MonadFail m, KubectlBasic context m+  )+  -- | Options+  => MinioOperatorOptions+  -> KubernetesClusterContext+  -> (MinioOperatorContext -> m a)+  -> m a+withMinioOperator options kcc action = do+  kubectlBinary <- askFile @"kubectl"+  withMinioOperator' kubectlBinary options kcc action++-- | Same as 'withMinioOperator', but allows you to pass in the @kubectl@ binary path.+withMinioOperator' :: (+  HasCallStack, MonadFail m, KubernetesBasic context m+  )+  -- | Path to @kubectl@ binary+  => FilePath+  -- | Options+  -> MinioOperatorOptions+  -> KubernetesClusterContext+  -> (MinioOperatorContext -> m a)+  -> m a+withMinioOperator' kubectlBinary (MinioOperatorOptions {..}) kcc action = do+  env <- askKubectlEnvironment kcc++  allYaml <- readCreateProcessWithLogging ((proc kubectlBinary ["kustomize", "github.com/minio/operator?ref=v6.0.1"]) { env = Just env }) ""++  when minioOperatorPreloadImages $ do+    let images = findAllImages (toText allYaml)++    forM_ images $ \image ->+      loadImageIfNecessary' kcc (ImageLoadSpecDocker image IfNotPresent)++  let create = createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) allYaml+                 >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  let namespaceToDestroy = fromMaybe "minio-operator" (findNamespace (toText allYaml))+  info [i|Detected MinIO operator namespace: #{namespaceToDestroy}|]++  let destroy = do+        -- I think this is a robust way to delete everything?+        -- Just doing "delete -f -" produces errors, seemingly because the minio-operator Namespace+        -- gets deleted first and then subsequent deletes encounter missing objects.+        -- If this doesn't work, we can fall back to just deleting the namespace below.+        -- But I think this will be better because it should pick up CRDs?+        createProcessWithLoggingAndStdin ((proc kubectlBinary ["delete", "-f", "-"+                                                              , "--ignore-not-found", "--wait=false", "--all=true"+                                                              ]) {+                                             env = Just env, delegate_ctlc = True }) allYaml+          >>= waitForProcess >>= (`shouldBe` ExitSuccess)++        -- createProcessWithLogging ((proc kubectlBinary ["delete", "namespace", toString namespaceToDestroy, "-f"]) {+        --                              env = Just env, delegate_ctlc = True+        --                              })+        --   >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  bracket_ create destroy (action MinioOperatorContext)++-- | Find the first "Namespace" resource in some multi-document YAML and extract its name+findNamespace :: Text -> Maybe Text+findNamespace = headMay . mapMaybe findNamespace' . T.splitOn "---\n"+  where+    findNamespace' :: Text -> Maybe Text+    findNamespace' (decode -> Right (V1Namespace {v1NamespaceKind=(Just "Namespace"), v1NamespaceMetadata=(Just meta)})) = v1ObjectMetaName meta+    findNamespace' _ = Nothing++    decode :: FromJSON a => Text -> Either Yaml.ParseException a+    decode = Yaml.decodeEither' . encodeUtf8
+ lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++Install MinIO S3 servers onto a Kubernetes cluster.++Such a server is provided as a generic 'TestS3Server', so that you can easily run the same tests against both Kubernetes environments and normal ones. See for example the @sandwich-contexts-minio@ package.++-}++module Test.Sandwich.Contexts.Kubernetes.MinioS3Server (+  introduceK8SMinioS3Server+  , introduceK8SMinioS3Server'++  -- * Bracket-style variants+  , withK8SMinioS3Server+  , withK8SMinioS3Server'++  -- * Types+  , MinioS3ServerOptions(..)+  , defaultMinioS3ServerOptions++  -- * Re-exports+  , testS3Server+  , TestS3Server(..)+  , HasTestS3Server+  ) where++import Control.Monad+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Data.String.Interpolate+import Data.Text as T+import Network.Minio+import Relude+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.HttpWaits+import Test.Sandwich.Contexts.Kubernetes+import Test.Sandwich.Contexts.Kubernetes.FindImages+import Test.Sandwich.Contexts.Kubernetes.Images+import Test.Sandwich.Contexts.Kubernetes.MinioOperator+import Test.Sandwich.Contexts.Kubernetes.MinioS3Server.Parsing+import Test.Sandwich.Contexts.Kubernetes.Util.UUID+import Test.Sandwich.Contexts.MinIO+import Test.Sandwich.Contexts.Nix+import UnliftIO.Exception+import UnliftIO.Process+import UnliftIO.Timeout+++data MinioS3ServerOptions = MinioS3ServerOptions {+  minioS3ServerNamespace :: Text+  , minioS3ServerKustomizationDir :: KustomizationDir+  , minioS3ServerPreloadImages :: Bool+  }+defaultMinioS3ServerOptions :: Text -> MinioS3ServerOptions+defaultMinioS3ServerOptions namespace = MinioS3ServerOptions {+  minioS3ServerNamespace = namespace+  , minioS3ServerKustomizationDir = KustomizationDirUrl "https://github.com/minio/operator/examples/kustomization/base?ref=v6.0.1"+  , minioS3ServerPreloadImages = True+  }++data KustomizationDir =+  -- | URL Kustomize dir to be downloaded+  KustomizationDirUrl Text+  -- | Local Kustomize dir+  | KustomizationDirLocal FilePath+  -- | A Nix callPackage-style derivation to produce the Kustomize dir+  | KustomizationDirNixDerivation Text+  deriving (Show, Eq)++-- | Introduce a MinIO server on a Kubernetes cluster.+-- Must have a 'minioOperator' context.+introduceK8SMinioS3Server :: (+  MonadMask m, Typeable context, KubectlBasicWithoutReader context m, HasMinioOperatorContext context+  )+  -- | Options+  => MinioS3ServerOptions+  -> SpecFree (LabelValue "testS3Server" TestS3Server :> context) m ()+  -> SpecFree context m ()+introduceK8SMinioS3Server options = do+  introduceWith "minio S3 server" testS3Server $ \action -> do+    kcc <- getContext kubernetesCluster+    moc <- getContext minioOperator+    withK8SMinioS3Server kcc moc options action++-- | Same as 'introduceK8SMinioS3Server', but allows you to pass in the 'KubernetesClusterContext'.+introduceK8SMinioS3Server' :: (+  MonadMask m, Typeable context, KubectlBasic context m, HasMinioOperatorContext context+  )+  => KubernetesClusterContext+  -- | Options+  -> MinioS3ServerOptions+  -> SpecFree (LabelValue "testS3Server" TestS3Server :> context) m ()+  -> SpecFree context m ()+introduceK8SMinioS3Server' kubernetesClusterContext options =+  introduceWith "minio S3 server" testS3Server $ \action -> do+    moc <- getContext minioOperator+    withK8SMinioS3Server kubernetesClusterContext moc options action++-- | Bracket-style variant of 'introduceK8SMinioS3Server'.+withK8SMinioS3Server :: (+  Typeable context, MonadMask m, MonadFail m, KubernetesBasic context m, HasFile context "kubectl"+  )+  => KubernetesClusterContext+  -> MinioOperatorContext+  -- | Options+  -> MinioS3ServerOptions+  -> (TestS3Server -> m [Result])+  -> m ()+withK8SMinioS3Server kcc moc options action = do+  kubectlBinary <- askFile @"kubectl"+  withK8SMinioS3Server' kubectlBinary kcc moc options action++-- | Same as 'withK8SMinioS3Server', but allows you to pass in the @kubectl@ binary.+withK8SMinioS3Server' :: forall m context. (+  Typeable context, MonadMask m, MonadFail m, KubernetesBasic context m+  )+  -- | Path to kubectl binary+  => FilePath+  -> KubernetesClusterContext+  -> MinioOperatorContext+  -- | Options+  -> MinioS3ServerOptions+  -> (TestS3Server -> m [Result])+  -> m ()+withK8SMinioS3Server' kubectlBinary kcc@(KubernetesClusterContext {..}) MinioOperatorContext (MinioS3ServerOptions {..}) action = do+  env <- askKubectlEnvironment kcc+  let runWithKubeConfig :: (HasCallStack) => String -> [String] -> m ()+      runWithKubeConfig prog args = do+        createProcessWithLogging ((proc prog args) { env = Just env, delegate_ctlc = True })+          >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  deploymentName <- ("minio-" <>) <$> makeUUID' 5++  -- let pool = "pool1"+  let port = 80++  kustomizationDir <- case minioS3ServerKustomizationDir of+    KustomizationDirLocal p -> pure p+    KustomizationDirUrl u -> pure (toString u)+    KustomizationDirNixDerivation d -> do+      getContextMaybe nixContext >>= \case+        Nothing -> expectationFailure [i|Couldn't find a Nix context to use with KustomizationDirNixDerivation|]+        Just nc -> buildNixCallPackageDerivation' nc d++  let busyboxImage = "busybox:1.36.1-musl"++  let create = do+        allYaml <- readCreateProcessWithLogging ((proc kubectlBinary ["kustomize", kustomizationDir]) { env = Just env, delegate_ctlc = True }) ""++        when minioS3ServerPreloadImages $ do+          let images = findAllImages (toText allYaml)++          forM_ images $ \image -> do+            debug [i|Preloading image: #{image}|]+            loadImageIfNecessary' kcc (ImageLoadSpecDocker image IfNotPresent)++          debug [i|Preloading image: #{busyboxImage}|]+          loadImageIfNecessary' kcc (ImageLoadSpecDocker busyboxImage IfNotPresent)++        (userAndPassword@(username, password), finalYaml) <- case transformKustomizeChunks (toString minioS3ServerNamespace) (toString deploymentName) (T.splitOn "---\n" (toText allYaml)) of+          Left err -> expectationFailure [i|Couldn't transform kustomize chunks: #{err}|]+          Right x -> pure x++        info [i|Got username and password: #{(username, password)}|]++        createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString finalYaml)+          >>= waitForProcess >>= (`shouldBe` ExitSuccess)++        return (userAndPassword, finalYaml)++  let destroy (_, finalYaml) = do+        info [i|-------------------------- DESTROYING --------------------------|]+        createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString finalYaml)+          >>= waitForProcess >>= (`shouldBe` ExitSuccess)+++  -- Create network policy allowing ingress/egress for v1.min.io/tenant = deploymentName+  let createNetworkPolicy = do+        let (policyName, discoverPodPolicyName, yaml) = networkPolicy deploymentName+        createProcessWithLoggingAndStdin ((proc kubectlBinary ["create", "--namespace", toString minioS3ServerNamespace, "-f", "-"]) { env = Just env, delegate_ctlc = True }) yaml+          >>= waitForProcess >>= (`shouldBe` ExitSuccess)+        pure (policyName, discoverPodPolicyName)+  let destroyNetworkPolicy (policyName, discoverPodPolicyName) = do+        runWithKubeConfig kubectlBinary ["delete", "NetworkPolicy", policyName, "--namespace", toString minioS3ServerNamespace]+        runWithKubeConfig kubectlBinary ["delete", "NetworkPolicy", discoverPodPolicyName, "--namespace", toString minioS3ServerNamespace]++  bracket createNetworkPolicy destroyNetworkPolicy $ \_ -> bracket create destroy $ \((username, password), _) -> do+    do+      uuid <- makeUUID+      p <- createProcessWithLogging ((proc kubectlBinary [+                                         "run", "discoverer-" <> toString uuid+                                         , "--rm", "-i"+                                         , "--attach"+                                         , [i|--image=#{busyboxImage}|]+                                         , "--image-pull-policy=IfNotPresent"+                                         , "--restart=Never"+                                         , "--command"+                                         , "--namespace", toString minioS3ServerNamespace+                                         , "--labels=app=discover-pod"+                                         , "--"+                                         , "sh", "-c", [i|until nc -vz minio 80; do echo "Waiting for minio..."; sleep 3; done;|]+                                         ]) { env = Just env })+      timeout 300_000_000 (waitForProcess p >>= (`shouldBe` ExitSuccess)) >>= \case+        Just () -> return ()+        Nothing -> expectationFailure [i|Failed to wait for minio to come online.|]++    info [__i|Ready to try port-forward:+              export KUBECONFIG=#{kubernetesClusterKubeConfigPath}+              kubectl --namespace #{minioS3ServerNamespace} port-forward "service/minio" 8080:#{port}|]++    withKubectlPortForward' kubectlBinary kubernetesClusterKubeConfigPath minioS3ServerNamespace (const True) Nothing "service/minio" port $ \(KubectlPortForwardContext {..}) -> do+      info [i|Did forward to localhost:#{kubectlPortForwardPort}|]++      let bucket = "bucket1"++      let testServ = TestS3Server {+            testS3ServerAddress = NetworkAddressTCP "localhost" kubectlPortForwardPort+            , testS3ServerContainerAddress = Just $ NetworkAddressTCP "minio" port+            , testS3ServerAccessKeyId = username+            , testS3ServerSecretAccessKey = password+            , testS3ServerBucket = Just bucket+            , testS3ServerHttpMode = HttpModeHttp+            }++      liftIO (runMinio (testS3ServerConnectInfo testServ) $ makeBucket bucket Nothing) >>= \case+        Left err -> expectationFailure [i|Failed to create bucket: #{err}|]+        Right () -> return ()++      waitUntilStatusCodeWithTimeout (4, 0, 3) (1_000_000 * 60 * 5) NoVerify (toString (testS3ServerEndpoint testServ))++      void $ action testServ+++networkPolicy :: Text -> (String, String, String)+networkPolicy deploymentName = (policyName, discoverPodPolicyName, yaml)+  where+    policyName = "minio-allow"+    discoverPodPolicyName = "discover-pod-allow"++    yaml = [__i|apiVersion: networking.k8s.io/v1+                kind: NetworkPolicy+                metadata:+                  name: #{policyName}+                spec:+                  podSelector:+                    matchLabels:+                      v1.min.io/tenant: "#{deploymentName}"++                  policyTypes:+                  - Ingress+                  - Egress++                  ingress:+                  - {}++                  egress:+                  - {}+                ---+                apiVersion: networking.k8s.io/v1+                kind: NetworkPolicy+                metadata:+                  name: #{discoverPodPolicyName}+                spec:+                  podSelector:+                    matchLabels:+                      app: discover-pod++                  policyTypes:+                  - Ingress+                  - Egress++                  ingress:+                  - {}++                  egress:+                  - {}+                |]
+ lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server/Parsing.hs view
@@ -0,0 +1,104 @@+++module Test.Sandwich.Contexts.Kubernetes.MinioS3Server.Parsing (+  parseMinioUserAndPassword+  , transformKustomizeChunks+  ) where++import Control.Lens+import Data.Aeson (FromJSON)+import qualified Data.Aeson as A+import Data.Aeson.Lens+import qualified Data.Map as M+import Data.String.Interpolate+import Data.Text as T+import qualified Data.Yaml as Yaml+import Kubernetes.OpenAPI.Model as Kubernetes+import Relude+import Safe (headMay)+import Test.Sandwich.Contexts.Kubernetes.Util.Aeson+import Text.Regex.TDFA+++parseMinioUserAndPassword :: Text -> Maybe (Text, Text)+parseMinioUserAndPassword txt = case (userValues, passwordValues) of+  (Just (_before, _fullMatch, _after, [user]), Just (_, _, _, [password])) -> Just (user, toText password)+  _ -> Nothing+  where+    userValues :: Maybe (Text, Text, Text, [Text]) = txt =~~ ([i|MINIO_ROOT_USER="([^"]*)"|] :: Text)+    passwordValues :: Maybe (Text, Text, Text, [Text]) = txt =~~ ([i|MINIO_ROOT_PASSWORD="([^"]*)"|] :: Text)++-- testInput :: Text+-- testInput = [__i|export MINIO_ROOT_USER="WXSTFUWIRS04LMGIMJGV"+--                  export MINIO_ROOT_PASSWORD="NCDCfTaiXcGHq8QRfSaXMAWOXgdrhpGwPSkoYMWf"|]++transformKustomizeChunks :: String -> String -> [Text] -> Either String ((Text, Text), Text)+transformKustomizeChunks namespace deploymentName initialChunks = do+  userAndPassword <- getUserAndPassword initialChunks++  return (userAndPassword, finalYaml)++  where+    finalYaml = initialChunks+              -- Don't include a kind: Namespace+              & Relude.filter (not . isNamespace)++              -- Set metadata.namespace on all values+              & fmap (setMetaNamespace namespace)++              -- Disable TLS+              & fmap disableTLS++              -- Set deployment name+              & fmap (setDeploymentNameAndPoolSize deploymentName)++              -- Combine everything into multi-document Yaml+              & T.intercalate "---\n"++getUserAndPassword :: [Text] -> Either String (Text, Text)+getUserAndPassword chunks = case headMay (mapMaybe getUserAndPassword' chunks) of+  Nothing -> Left "Couldn't find user/password YAML."+  Just x -> Right x+  where+    getUserAndPassword' :: Text -> Maybe (Text, Text)+    getUserAndPassword' (decode -> Right (V1Secret {v1SecretMetadata=(Just (V1ObjectMeta {v1ObjectMetaName=(Just "storage-configuration")}))+                                                   , v1SecretStringData=(Just (M.lookup "config.env" -> Just t))+                                                   }))+      = parseMinioUserAndPassword t+    getUserAndPassword' _ = Nothing++isNamespace :: Text -> Bool+isNamespace (decode -> Right (A.Object (aesonLookup "kind" -> Just (A.String "Namespace")))) = True+isNamespace _ = False++setMetaNamespace :: String -> Text -> Text+setMetaNamespace namespace (decode -> Right (A.Object obj1@(aesonLookup "metadata" -> Just (A.Object obj2@(aesonLookup "namespace" -> Just (A.String _)))))) =+  decodeUtf8 (Yaml.encode obj1')+  where+    obj1' :: A.Value+    obj1' = A.Object (aesonInsert "metadata" obj2' obj1)++    obj2' :: A.Value+    obj2' = A.Object (aesonInsert "namespace" (A.String (toText namespace)) obj2)+setMetaNamespace _ t = t++-- Do the steps to disable TLS in the tenant CRD.+-- See https://min.io/docs/minio/kubernetes/upstream/reference/operator-crd.html#tenantspec+disableTLS :: Text -> Text+disableTLS (decode -> Right x@(A.Object (aesonLookup "kind" -> Just (A.String "Tenant")))) = decodeUtf8 (Yaml.encode x')+  where+    x' = x+       & set (_Object . ix "spec" . _Object . ix "requestAutoCert") (A.Bool False)+       & set (_Object . ix "spec" . _Object . at "externalCertSecret") Nothing+disableTLS t = t++setDeploymentNameAndPoolSize :: String -> Text -> Text+setDeploymentNameAndPoolSize deploymentName (decode -> Right x@(A.Object (aesonLookup "kind" -> Just (A.String "Tenant")))) = decodeUtf8 (Yaml.encode x')+  where+    x' = x+       & set (_Object . ix "metadata" . _Object . ix "name") (A.String (toText deploymentName))+       & set (_Object . ix "spec" . _Object . ix "pools" . _Array . ix 0 . _Object . ix "servers") (A.Number 1)+setDeploymentNameAndPoolSize _ t = t++decode :: FromJSON a => Text -> Either Yaml.ParseException a+decode = Yaml.decodeEither' . encodeUtf8
+ lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|+Helper module for working with Kubernetes namespaces.+-}++module Test.Sandwich.Contexts.Kubernetes.Namespace (+  withKubernetesNamespace+  , withKubernetesNamespace'++  , createKubernetesNamespace+  , destroyKubernetesNamespace+  ) where++import Control.Monad+import Data.String.Interpolate+import Relude hiding (force)+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Kubectl+import Test.Sandwich.Contexts.Kubernetes.Types+import UnliftIO.Exception+import UnliftIO.Process+++-- | Around-style node to create a Kubernetes namespace, and destroy it at the end.+--+-- If you're installing something via Helm 3, you may not need this as you can just pass @--create-namespace@.+withKubernetesNamespace :: (+  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))++-- | Same as 'withKubernetesNamespace', but works in an arbitrary monad with reader context.+withKubernetesNamespace' :: (+  KubectlBasic context m+  )+  -- | Namespace to create+  => Text+  -> m a+  -> m a+withKubernetesNamespace' namespace = bracket_ (createKubernetesNamespace namespace) (destroyKubernetesNamespace False namespace)++-- | Create a Kubernetes namespace.+createKubernetesNamespace :: (+  KubectlBasic context m+  )+  -- | Namespace name+  => Text+  -> m ()+createKubernetesNamespace namespace = do+  let args = ["create", "namespace", toString namespace]+  (kubectl, env) <- askKubectlArgs+  createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++-- | Destroy a Kubernetes namespace.+destroyKubernetesNamespace :: (+  KubectlBasic context m+  )+  -- | Whether to pass @--force@+  => Bool+  -- | Namespace name+  -> Text+  -> m ()+destroyKubernetesNamespace force namespace = do+  let args = ["delete", "namespace", toString namespace]+           <> if force then ["--force"] else []+  (kubectl, env) <- askKubectlArgs+  createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+ lib/Test/Sandwich/Contexts/Kubernetes/Run.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Sandwich.Contexts.Kubernetes.Run where++import Test.Sandwich.Contexts.Kubernetes.Types+import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.String.Interpolate+import Data.Text as T+import Kubernetes.OpenAPI.Client as Kubernetes+import Kubernetes.OpenAPI.Core as Kubernetes+import Kubernetes.OpenAPI.MimeTypes+import Network.HTTP.Client+import Relude+import Test.Sandwich+import UnliftIO.Exception+++type Constraints context m = (MonadIO m, MonadThrow m, MonadUnliftIO m, MonadLogger m, MonadMask m, MonadReader context m)++instance Exception MimeError++-- * Run Exception++k8sRunException :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m, HasKubernetesClusterContext context)+  => KubernetesRequest req contentType res accept -> m res+k8sRunException req = do+  (manager, clientConfig) <- kubernetesClusterClientConfig <$> getContext kubernetesCluster+  k8sRunException' manager clientConfig req++k8sRunException' :: (MimeUnrender accept res, MimeType contentType, Produces req accept, Constraints context m)+  => Manager -> KubernetesClientConfig -> KubernetesRequest req contentType res accept -> m res+k8sRunException' manager clientConfig req = k8sRunEither'' manager clientConfig req >>= \case+  Left err -> throwIO err+  Right x -> return x++-- * Run Either++k8sRunEither :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m, HasKubernetesClusterContext context)+  => KubernetesRequest req contentType res accept -> m (Either Text res)+k8sRunEither req = do+  (manager, clientConfig) <- kubernetesClusterClientConfig <$> getContext kubernetesCluster+  k8sRunEither' manager clientConfig req++k8sRunEither' :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m)+  => Manager -> KubernetesClientConfig -> KubernetesRequest req contentType res accept -> m (Either Text res)+k8sRunEither' manager clientConfig req = first show <$> k8sRunEither'' manager clientConfig req++k8sRunEither'' :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m)+  => Manager -> KubernetesClientConfig -> KubernetesRequest req contentType res accept -> m (Either MimeError res)+k8sRunEither'' k8sManager k8sClientConfig req = do+  MimeResult parsedResult _httpResponse <- liftIO (dispatchMime k8sManager k8sClientConfig req)++  let successMessage = case parsedResult of+        Left err -> "FAIL: " <> show err+        _ -> "SUCCESS" :: Text++  debug [i|Kubernetes request: #{rMethod req} to #{BL.intercalate "/" $ rUrlPath req} = #{successMessage}|]++  return parsedResult
+ lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++{-|++Install [SeaweedFS](https://github.com/seaweedfs/seaweedfs) deployments on a Kubernetes cluster.++-}++module Test.Sandwich.Contexts.Kubernetes.SeaweedFS (+  introduceSeaweedFS++  -- * Bracket-style variants+  , withSeaweedFS+  , withSeaweedFS'++  -- * Types+  , SeaweedFSOptions(..)+  , defaultSeaweedFSOptions++  , seaweedFs+  , SeaweedFSContext(..)+  , HasSeaweedFSContext+  ) where++import Control.Monad+import Data.Aeson as A+import qualified Data.List as L+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Yaml as Yaml+import Relude hiding (withFile)+import System.Exit+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Images (loadImage')+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.Aeson+import Test.Sandwich.Contexts.Nix+import UnliftIO.Environment+import UnliftIO.IO (withFile)+import UnliftIO.Process+import UnliftIO.Temporary+++data SeaweedFSContext = SeaweedFSContext {+  seaweedFsOptions :: SeaweedFSOptions+  } deriving (Show)++data SeaweedFSOptions = SeaweedFSOptions {+  seaweedFsImage :: Text+  , seaweedFsBaseName :: Text+  , seaweedFsMasterReplicas :: Int+  , seaweedFsFilerReplicas :: Int+  , seaweedFsVolumeReplicas :: Int+  , seaweedFsVolumeServerDiskCount :: Int+  , seaweedFsVolumeSizeLimitMb :: Int+  , seaweedFsVolumeStorageRequest :: Text+  } deriving (Show)+defaultSeaweedFSOptions :: SeaweedFSOptions+defaultSeaweedFSOptions = SeaweedFSOptions {+  seaweedFsImage = "chrislusf/seaweedfs:3.73"+  , seaweedFsBaseName = "seaweed1"+  , seaweedFsMasterReplicas = 3+  , seaweedFsFilerReplicas = 2+  , seaweedFsVolumeReplicas = 1+  , seaweedFsVolumeServerDiskCount = 1+  , seaweedFsVolumeSizeLimitMb = 1024+  , seaweedFsVolumeStorageRequest = "2Gi"+  }++seaweedFs :: Label "seaweedFs" SeaweedFSContext+seaweedFs = Label+type HasSeaweedFSContext context = HasLabel context "seaweedFs" SeaweedFSContext++type ContextWithSeaweedFS context =+  LabelValue "seaweedFs" SeaweedFSContext+  :> LabelValue "file-kubectl" (EnvironmentFile "kubectl")+  :> context++-- | Introduce [SeaweedFS](https://github.com/seaweedfs/seaweedfs) on the Kubernetes cluster, in a given namespace.+introduceSeaweedFS :: (+  KubernetesClusterBasicWithoutReader context m, HasNixContext context+  )+  -- | Namespace+  => Text+  -> SeaweedFSOptions+  -> SpecFree (ContextWithSeaweedFS context) m ()+  -> SpecFree context m ()+introduceSeaweedFS namespace options = introduceBinaryViaNixPackage @"kubectl" "kubectl" . introduceWith "introduce SeaweedFS" seaweedFs (void . withSeaweedFS namespace options)++-- | Bracket-style version of 'introduceSeaweedFS'.+withSeaweedFS :: forall context m a. (+  HasCallStack, MonadFail m, KubectlBasic context m, HasNixContext context+  )+  -- | Namespace+  => Text+  -> SeaweedFSOptions+  -> (SeaweedFSContext -> m a)+  -> m a+withSeaweedFS namespace options action = do+  kcc <- getContext kubernetesCluster+  kubectlBinary <- askFile @"kubectl"+  withSeaweedFS' kcc kubectlBinary namespace options action++-- | Same as 'withSeaweedFS', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path.+withSeaweedFS' :: forall context m a. (+  HasCallStack, MonadFail m, NixContextBasic context m+  )+  -- | Cluster context+  => KubernetesClusterContext+  -- | Path to @kubectl@ binary+  -> FilePath+  -- | Namespace+  -> Text+  -> SeaweedFSOptions+  -> (SeaweedFSContext -> m a)+  -> m a+withSeaweedFS' kcc@(KubernetesClusterContext {kubernetesClusterKubeConfigPath}) kubectlBinary namespace options action = do+  baseEnv <- getEnvironment++  NixContext {..} <- getContext nixContext++  let cp = proc nixContextNixBinary ["build", "--impure"+                                    , "--extra-experimental-features", "nix-command"+                                    , "--expr", seaweedFsOperatorDerivation+                                    , "--json"]++  operatorJson <- withFile "/dev/null" WriteMode $ \hNull ->+    readCreateProcess (cp { std_err = UseHandle hNull }) ""++  operatorPath <- case A.eitherDecodeStrict (encodeUtf8 operatorJson) of+    Right (A.Array (V.toList -> ((A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "out" -> Just (A.String p))))):_))) -> pure p+    x -> expectationFailure [i|Couldn't parse seaweedfs-operator path: #{x}|]++  info [i|Got operator path: #{operatorPath}|]++  -- Build a Nix environment with some tools needed by the operator+  nixEnvPath <- buildNixSymlinkJoin ["coreutils", "gnumake", "go", "stdenv", "which"]+  info [i|Built Nix environment for operator builds: #{nixEnvPath}|]++  let originalSearchPathParts = maybe [] splitSearchPath (L.lookup "PATH" baseEnv)+  let finalPath = (nixEnvPath </> "bin") : takeDirectory kubectlBinary : originalSearchPathParts+                & fmap toText+                & T.intercalate (toText [searchPathSeparator])+                & toString++  let env = baseEnv+          & (("KUBECONFIG", kubernetesClusterKubeConfigPath) :)+          & (("PATH", finalPath) :)+          & L.nubBy (\x y -> fst x == fst y)++  withSystemTempDirectory "seaweedfs-operator" $ \dir -> do+    let target = dir </> "seaweefs-operator"+    _ <- readCreateProcess (proc "cp" ["-r", toString operatorPath, target]) ""+    _ <- readCreateProcess (proc "chmod" ["-R", "u+w", target]) ""++    let runOperatorCmd cmd extraEnv = createProcessWithLogging (+          (shell cmd) {+              env = Just (env <> extraEnv)+              , cwd = Just target+              }+          ) >>= waitForProcess >>= (`shouldBe` ExitSuccess)++    info [i|------------------ Building and uploading SeaweedFS Docker image ------------------|]++    let initialImageName = "seaweedfs/seaweedfs-operator:v0.0.1"++    info [i|Doing make docker-build|]+    runOperatorCmd "make docker-build" [("IMG", toString initialImageName)]++    newImageName <- loadImage' kcc (ImageLoadSpecDocker initialImageName IfNotPresent)+    info [i|Loaded image into cluster as: #{newImageName}|]++    info [i|------------------ Installing SeaweedFS operator ------------------|]++    info [i|Doing make install|]+    runOperatorCmd "make install" [("IMG", toString newImageName)]+    info [i|Doing make deploy|]+    runOperatorCmd "make deploy" [("IMG", toString newImageName)]++    info [i|------------------ Creating SeaweedFS deployment ------------------|]++    let val = decodeUtf8 $ A.encode $ example namespace options+    createProcessWithLoggingAndStdin ((shell [i|#{kubectlBinary} create -f -|]) { env = Just env }) val+      >>= waitForProcess >>= (`shouldBe` ExitSuccess)++    action $ SeaweedFSContext {+      seaweedFsOptions = options+      }+++example :: Text -> SeaweedFSOptions -> Yaml.Value+example namespace (SeaweedFSOptions {..}) = let Right x = Yaml.decodeEither' raw in x+ where raw = [i|apiVersion: seaweed.seaweedfs.com/v1+kind: Seaweed+metadata:+  namespace: #{namespace}+  name: #{seaweedFsBaseName}+spec:+  image: #{seaweedFsImage}+  volumeServerDiskCount: #{seaweedFsVolumeServerDiskCount}+  hostSuffix: seaweed.abcdefg.com+  master:+    replicas: #{seaweedFsMasterReplicas}+    volumeSizeLimitMB: #{seaweedFsVolumeSizeLimitMb}+  volume:+    replicas: #{seaweedFsVolumeReplicas}+    requests:+      storage: #{seaweedFsVolumeStorageRequest}+  filer:+    replicas: #{seaweedFsFilerReplicas}+    config: |+      [leveldb2]+      enabled = true+      dir = "/data/filerldb2"+|]++seaweedFsOperatorDerivation = [__i|with import <nixpkgs> {}; fetchFromGitHub {+                                     owner = "seaweedfs";+                                     repo = "seaweedfs-operator";+                                     rev = "6fa4c24d47c57daa10a084e3a5598efbb8d808c8";+                                     sha256 = "sha256-gFFIG2tglzvXoqzUvbzWAG2Bg2RwCCsuX0tXwV95D/0=";+                                   }+                                  |]
+ lib/Test/Sandwich/Contexts/Kubernetes/Types.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Sandwich.Contexts.Kubernetes.Types where++import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Kubernetes.OpenAPI.Core as Kubernetes+import Network.HTTP.Client+import Relude+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import qualified Text.Show+++instance Show Manager where+  show _ = "<HTTP manager>"++-- * Kubernetes cluster++data KubernetesClusterType =+  KubernetesClusterKind { kubernetesClusterTypeKindBinary :: FilePath+                        , kubernetesClusterTypeKindClusterName :: Text+                        , kubernetesClusterTypeKindClusterDriver :: Text+                        , kubernetesClusterTypeKindClusterEnvironment :: Maybe [(String, String)]+                        }+  | KubernetesClusterMinikube { kubernetesClusterTypeMinikubeBinary :: FilePath+                              , kubernetesClusterTypeMinikubeProfileName :: Text+                              , kubernetesClusterTypeMinikubeFlags :: [Text]+                              }+  deriving (Show, Eq)++data KubernetesClusterContext = KubernetesClusterContext {+  kubernetesClusterName :: Text+  , kubernetesClusterKubeConfigPath :: FilePath+  , kubernetesClusterNumNodes :: Int+  , kubernetesClusterClientConfig :: (Manager, Kubernetes.KubernetesClientConfig)+  , kubernetesClusterType :: KubernetesClusterType+  } deriving (Show)++kubernetesCluster :: Label "kubernetesCluster" KubernetesClusterContext+kubernetesCluster = Label+type HasKubernetesClusterContext context = HasLabel context "kubernetesCluster" KubernetesClusterContext++-- * Contexts with MonadReader++type KubernetesBasic context m = (+  MonadLoggerIO m+  , MonadUnliftIO m+  , HasBaseContextMonad context m+  )++type KubernetesClusterBasic context m = (+  KubernetesBasic context m+  , HasKubernetesClusterContext context+  )++type KubectlBasic context m = (+  KubernetesClusterBasic context m+  , HasFile context "kubectl"+  )++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]+kubernetesClusterImages = Label+type HasKubernetesClusterImagesContext context = HasLabel context "kubernetesClusterImages" [Text]++data ImagePullPolicy = Always | IfNotPresent | Never+  deriving (Show, Eq)++data ImageLoadSpec =+  -- | A @.tar@ or @.tar.gz@ file+  ImageLoadSpecTarball FilePath+  -- | An image pulled via Docker+  | ImageLoadSpecDocker { imageName :: Text+                        , pullPolicy :: ImagePullPolicy }+  -- | An image pulled via Podman+  | ImageLoadSpecPodman { imageName :: Text+                        , pullPolicy :: ImagePullPolicy }+  deriving (Show, Eq)
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/Aeson.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}++module Test.Sandwich.Contexts.Kubernetes.Util.Aeson where++import qualified Data.Aeson as A+import Data.Char+import qualified Data.List as L+import Data.Text hiding (toLower)+import Relude++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key             as A+import qualified Data.Aeson.KeyMap          as HM+#else+import Data.Hashable+import qualified Data.HashMap.Strict        as HM+#endif+++textKeys :: A.Object -> [Text]+#if MIN_VERSION_aeson(2,0,0)+textKeys = fmap A.toText . HM.keys+#else+textKeys = HM.keys+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonLookup :: Text -> HM.KeyMap v -> Maybe v+aesonLookup = HM.lookup . A.fromText+#else+aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonInsert :: Text -> v -> HM.KeyMap v -> HM.KeyMap v+aesonInsert t = HM.insert (A.fromText t)+#else+aesonInsert :: (Eq k, Hashable k) => k -> v -> HM.HashMap k v -> HM.HashMap k v+aesonInsert = HM.insert+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonDelete :: Text -> HM.KeyMap v -> HM.KeyMap v+aesonDelete t = HM.delete (A.fromText t)+#else+aesonDelete :: (Eq k, Hashable k) => k -> HM.HashMap k v -> HM.HashMap k v+aesonDelete = HM.delete+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonToList :: HM.KeyMap v -> [(A.Key, v)]+aesonToList = HM.toList+#else+aesonToList :: HM.HashMap k v -> [(k, v)]+aesonToList = HM.toList+#endif+++dropNAndCamelCase :: Int -> String -> String+dropNAndCamelCase n = lowercaseFirst . L.drop n++lowercaseFirst :: [Char] -> [Char]+lowercaseFirst (x:xs) = (toLower x) : xs+lowercaseFirst [] = []
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/Container.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++module Test.Sandwich.Contexts.Kubernetes.Util.Container (+  ContainerSystem (..)++  , isInContainer++  , containerPortToHostPort++  , containerNameToContainerId++  , waitForHealth+  ) where++import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.Aeson as A+import Data.Aeson.TH as A+import qualified Data.List as L+import qualified Data.Map as M+import Data.String.Interpolate+import qualified Data.Text as T+import Network.Socket (PortNumber)+import Relude+import Safe+import System.Exit+import Test.Sandwich+import qualified Text.Show+import UnliftIO.Process+++data ContainerSystem = ContainerSystemDocker | ContainerSystemPodman+  deriving (Eq)++instance Show ContainerSystem where+  show ContainerSystemDocker = "docker"+  show ContainerSystemPodman = "podman"++isInContainer :: MonadIO m => m Bool+isInContainer = do+  output <- toText <$> readCreateProcess (shell "cat /proc/1/sched | head -n 1") ""+  return $ not $+    ("init" `T.isInfixOf` output)+    || ("systemd" `T.isInfixOf` output)+    || ("bwrap" `T.isInfixOf` output)++waitForHealth :: forall m. (HasCallStack, MonadLoggerIO m, MonadMask m) => ContainerSystem -> Text -> m ()+waitForHealth containerSystem containerID = do+  let policy = limitRetriesByCumulativeDelay (60 * 1_000_000) $ capDelay 1_000_000 $ exponentialBackoff 1000+  recoverAll policy $ \_ -> do+    health <- (T.strip . toText) <$> (readCreateProcess (+      shell [i|#{containerSystem} inspect --format "{{json .State.Health.Status }}" #{containerID}|]) ""+      )++    case health of+      "\"healthy\"" -> return ()+      _ -> do+        -- Try running the health check manually, when possible.+        -- This is a workaround for rootless podman failing to have working healthchecks.+        when (containerSystem == ContainerSystemPodman) $ do+          -- TODO: use createProcessWithLogging here?+          (exitCode, sout, serr) <- readCreateProcessWithExitCode (proc "podman" ["healthcheck", "run", toString containerID]) ""+          when (exitCode /= ExitSuccess) $ do+            warn [i|Failed to manually run healthcheck. Code: #{exitCode}. Stdout: '#{sout}'. Stderr: '#{serr}'.|]++        expectationFailure [i|Health was: #{health}|]+++data HostPortInfo = HostPortInfo {+  hostPortInfoHostIp :: Text+  , hostPortInfoHostPort :: Text+  }+deriveJSON (A.defaultOptions { A.fieldLabelModifier = L.drop (L.length ("hostPortInfo" :: String)) }) ''HostPortInfo++-- | Map a port number inside a container to a port number on the host.+containerPortToHostPort :: (HasCallStack, MonadIO m) => ContainerSystem -> Text -> PortNumber -> m PortNumber+containerPortToHostPort containerSystem containerName containerPort = do+  let inspectPortCmd = [i|#{containerSystem} inspect --format='{{json .NetworkSettings.Ports}}' #{containerName}|]++  rawNetworkSettings <- liftIO (readCreateProcessWithExitCode (shell inspectPortCmd) "") >>= \case+    (ExitSuccess, sout, _serr) -> return $ T.strip $ toText sout+    (ExitFailure n, sout, serr) -> expectationFailure [i|Failed to read container ports (error code #{n}). Stdout: '#{sout}'. Stderr: '#{serr}'.|]++  networkSettings :: Map Text [HostPortInfo] <- case A.eitherDecode (encodeUtf8 rawNetworkSettings) of+    Left err -> expectationFailure [i|Failed to decode network settings: #{err}. Settings were #{rawNetworkSettings}.|]+    Right x -> pure x++  rawPort <- case M.lookup [i|#{containerPort}/tcp|] networkSettings of+    Just (x:_) -> pure $ hostPortInfoHostPort x+    _ -> expectationFailure [i|Couldn't find any host ports corresponding to container port #{containerPort}. Network settings: #{A.encode networkSettings}|]++  case readMay (toString rawPort) of+    Just x -> pure x+    Nothing -> expectationFailure [i|Couldn't read container port number: '#{rawPort}'|]++-- | Convert a container name to a container ID.+containerNameToContainerId :: (HasCallStack, MonadIO m) => ContainerSystem -> Text -> m Text+containerNameToContainerId containerSystem containerName = do+  let cmd = [i|#{containerSystem} inspect --format='{{.Id}}' #{containerName}|]+  liftIO (readCreateProcessWithExitCode (shell cmd) "") >>= \case+    (ExitSuccess, sout, _serr) -> return $ T.strip $ toText sout+    (ExitFailure n, sout, serr) -> expectationFailure [i|Failed to obtain container ID for container named '#{containerName}'. Code: #{n}. Stdout: '#{sout}'. Stderr: '#{serr}'.|]
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/Exception.hs view
@@ -0,0 +1,13 @@++module Test.Sandwich.Contexts.Kubernetes.Util.Exception where++import Control.Monad.IO.Unlift+import Relude+import Test.Sandwich.Misc+import UnliftIO.Exception+++leftOnException :: (MonadUnliftIO m) => m (Either Text a) -> m (Either Text a)+leftOnException = handleAny $ \e -> return $ Left $ case fromException e of+  Just (Reason _ msg) -> toText msg+  _ -> show e
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.Util.Images (+  dockerPullIfNecessary+  , isDockerImagePresent++  , podmanPullIfNecessary+  , isPodmanImagePresent++  , readImageName+  , readUncompressedImageName+  , imageLoadSpecToImageName+  ) where++import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.Aeson as A+import qualified Data.ByteString.Lazy as BL+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Vector as V+import Relude+import Safe+import System.Exit+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Kubernetes.Util.Aeson+import UnliftIO.Directory+import UnliftIO.Process+import UnliftIO.Temporary+++-- * Docker++-- | Pull an image using Docker if it isn't already present.+-- Returns 'True' if a pull was done.+dockerPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> ImagePullPolicy -> m Bool+dockerPullIfNecessary = commonPullIfNecessary "docker"++isDockerImagePresent :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> m Bool+isDockerImagePresent = isImagePresentCommon "docker"++-- * Podman++-- | Pull an image using Docker if it isn't already present.+-- Returns 'True' if a pull was done.+podmanPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> ImagePullPolicy -> m Bool+podmanPullIfNecessary = commonPullIfNecessary "podman"++isPodmanImagePresent :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> m Bool+isPodmanImagePresent = isImagePresentCommon "podman"++-- * Common++commonPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => String -> Text -> ImagePullPolicy -> m Bool+commonPullIfNecessary binary image pullPolicy = isImagePresentCommon binary image >>= \case+  True ->+    if | pullPolicy == Always -> doPull+       | otherwise -> return False+  False ->+    if | pullPolicy == Never -> expectationFailure [i|Docker pull policy was "Never" but image wasn't present: '#{image}'|]+       | otherwise -> doPull+  where+    doPull = do+      createProcessWithLogging (proc binary ["pull", toString image])+        >>= waitForProcess >>= (`shouldBe` ExitSuccess)+      return True++isImagePresentCommon :: (MonadUnliftIO m, MonadLoggerIO m) => String -> Text -> m Bool+isImagePresentCommon binary image = do+  createProcessWithLogging (proc binary ["inspect", "--type=image", toString image]) >>= waitForProcess >>= \case+    ExitSuccess -> return True+    ExitFailure _ -> return False++-- * Image name reading++readImageName :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => FilePath -> m Text+readImageName path = doesDirectoryExist path >>= \case+  True -> readUncompressedImageName path+  False -> case takeExtension path of+    ".tar" -> extractFromTarball+    ".gz" -> extractFromTarball+    _ -> expectationFailure [i|readImageName: unexpected extension in #{path}. Wanted .tar, .tar.gz, or uncompressed directory.|]+  where+    extractFromTarball = do+      files <- readCreateProcessWithLogging (proc "tar" ["tf", path]) ""+      manifestFileName <- case headMay [t | t <- T.words (toText files), "manifest.json" `T.isInfixOf` t] of+        Just f -> pure $ toString $ T.strip f+        Nothing -> expectationFailure [i|readImageName: couldn't find manifest file in #{path}|]++      withSystemTempDirectory "manifest.json" $ \dir -> do+        _ <- readCreateProcessWithLogging ((proc "tar" ["xvf", path, manifestFileName]) { cwd = Just dir }) ""+        liftIO (BL.readFile (dir </> "manifest.json")) >>= getImageNameFromManifestJson path++readUncompressedImageName :: (HasCallStack, MonadIO m) => FilePath -> m Text+readUncompressedImageName path = liftIO (BL.readFile (path </> "manifest.json")) >>= getImageNameFromManifestJson path++getImageNameFromManifestJson :: (HasCallStack, MonadIO m) => FilePath -> LByteString -> m Text+getImageNameFromManifestJson path contents = do+  case A.eitherDecode contents of+    Left err -> expectationFailure [i|Couldn't decode manifest.json: #{err}|]+    Right (A.Array entries) -> case concatMap getRepoTags entries of+      (x:_) -> pure x+      [] -> expectationFailure [i|Didn't find a repo tag for image at #{path}|]+    Right x -> expectationFailure [i|Unexpected manifest.json format: #{x}|]++  where+    getRepoTags :: A.Value -> [Text]+    getRepoTags (A.Object (aesonLookup "RepoTags" -> Just (A.Array repoItems))) = [t | A.String t <- V.toList repoItems]+    getRepoTags _ = []++imageLoadSpecToImageName :: (MonadUnliftIO m, MonadLogger m) => ImageLoadSpec -> m Text+imageLoadSpecToImageName (ImageLoadSpecTarball image) = readImageName image+imageLoadSpecToImageName (ImageLoadSpecDocker image _) = pure image+imageLoadSpecToImageName (ImageLoadSpecPodman image _) = pure image
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/Nix.hs view
@@ -0,0 +1,29 @@++module Test.Sandwich.Contexts.Kubernetes.Util.Nix (+  withWritableBinaryCache+  ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.Logger+import Data.String.Interpolate+import Relude+import System.FilePath+import System.IO.Temp+import Test.Sandwich.Logging+import UnliftIO.Directory+import UnliftIO.Process+++withWritableBinaryCache :: (MonadIO m, MonadMask m, MonadLogger m) => Maybe FilePath -> (Maybe FilePath -> m a) -> m a+withWritableBinaryCache Nothing action = action Nothing+withWritableBinaryCache (Just readOnlyPath) action =+  withSystemTempDirectory "writable-binary-cache" $ \dir -> do+    let path = dir </> "cache"+    info [i|Putting writable binary cache at: #{path}|]+    _ <- readCreateProcess (proc "cp" ["-ra", readOnlyPath, path]) ""++    -- The cache needs a writable realisations folder+    _ <- readCreateProcess (proc "chmod" ["a+w", path]) ""+    createDirectoryIfMissing True (path </> "realisations")++    action $ Just path
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/Ports.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Test.Sandwich.Contexts.Kubernetes.Util.Ports where++import Control.Monad.Catch (MonadCatch, catch)+import Control.Retry+import Network.Socket+import Relude+import System.Random (randomRIO)+++-- | Find an unused port in a given range+findFreePortInRange' :: forall m. (+  MonadIO m, MonadCatch m+  ) => RetryPolicy -> (PortNumber, PortNumber) -> [PortNumber] -> m (Maybe PortNumber)+findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange')+  where getAcceptableCandidate :: m PortNumber+        getAcceptableCandidate = do+          candidate <- liftIO (fromInteger <$> randomRIO (fromIntegral start, fromIntegral end))+          if | candidate `elem` blacklist -> getAcceptableCandidate+             | otherwise -> return candidate++        findFreePortInRange' :: m (Maybe PortNumber)+        findFreePortInRange' = do+          candidate <- getAcceptableCandidate+          isPortFree candidate >>= \case+            False -> return Nothing+            True -> return $ Just candidate++isPortFree :: (MonadIO m, MonadCatch m) => PortNumber -> m Bool+isPortFree candidate = catch (tryOpenAndClosePort candidate >> return True)+                             (\(_ :: SomeException) -> return False)++tryOpenAndClosePort :: MonadIO m => PortNumber -> m PortNumber+tryOpenAndClosePort port = liftIO $ do+  sock <- socket AF_INET Stream 0+  setSocketOption sock ReuseAddr 1+  let hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }+  getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port) >>= \case+    ((AddrInfo {addrAddress=addr}):_) -> do+      bind sock addr+      close sock+      return $ fromIntegral port+    [] -> error "Couldn't resolve address 127.0.0.1"++findFreePortInRange :: (+  MonadIO m, MonadCatch m+  ) => (PortNumber, PortNumber) -> [PortNumber] -> m (Maybe PortNumber)+findFreePortInRange = findFreePortInRange' (limitRetries 50)++-- | Find an unused port in the ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers+-- This works without a timeout since there should always be a port in there somewhere;+-- it might be advisable to wrap in a timeout anyway.+findFreePort :: (MonadIO m, MonadCatch m) => m (Maybe PortNumber)+findFreePort = findFreePortInRange (49152, 65535) []++findFreePortOrException :: (MonadIO m, MonadCatch m) => m PortNumber+findFreePortOrException = findFreePortOrException' (const True)++findFreePortOrException' :: (MonadIO m, MonadCatch m) => (PortNumber -> Bool) -> m PortNumber+findFreePortOrException' isAcceptable = findFreePort >>= \case+  Just port+    | isAcceptable port -> return port+    | otherwise -> findFreePortOrException' isAcceptable+  Nothing -> error "Couldn't find free port"++findFreePortNotIn :: (MonadIO m, MonadCatch m) => [PortNumber] -> m (Maybe PortNumber)+findFreePortNotIn = findFreePortInRange (49152, 65535)
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/SocketUtil.hs view
@@ -0,0 +1,43 @@+module Test.Sandwich.Contexts.Kubernetes.Util.SocketUtil (+  isPortOpen+  , simpleSockAddr+  ) where++-- Taken from+-- https://stackoverflow.com/questions/39139787/i-want-to-check-whether-or-not-a-certain-port-is-open-haskell+-- https://gist.github.com/nh2/0a1442eb71ec0405a1e3ce83a467dfde#file-socketutils-hs++import Foreign.C.Error (Errno(..), eCONNREFUSED)+import GHC.IO.Exception (IOException(..))+import Network.Socket (Family(AF_INET), PortNumber, SocketType(Stream), SockAddr(SockAddrInet), socket, connect, close', tupleToHostAddress)+import Relude+import UnliftIO.Exception++-- | Checks whether @connect()@ to a given TCPv4 `SockAddr` succeeds or+-- returns `eCONNREFUSED`.+--+-- Rethrows connection exceptions in all other cases (e.g. when the host+-- is unroutable).+isPortOpen :: SockAddr -> IO Bool+isPortOpen sockAddr = do+  bracket (socket AF_INET Stream 6 {- TCP -}) close' $ \sock -> do+    res <- try $ connect sock sockAddr+    case res of+      Right () -> return True+      Left e ->+        if (Errno <$> ioe_errno e) == Just eCONNREFUSED+          then return False+          else throwIO e+++-- | Creates a `SockAttr` from host IP and port number.+--+-- Example:+-- > simpleSockAddr (127,0,0,1) 8000+simpleSockAddr :: (Word8, Word8, Word8, Word8) -> PortNumber -> SockAddr+simpleSockAddr addr port = SockAddrInet port (tupleToHostAddress addr)+++-- Example usage:+-- > isPortOpen (simpleSockAddr (127,0,0,1) 8000)+-- True
+ lib/Test/Sandwich/Contexts/Kubernetes/Util/UUID.hs view
@@ -0,0 +1,22 @@++module Test.Sandwich.Contexts.Kubernetes.Util.UUID where++import qualified Data.List as L+import Data.Text as T+import Relude+import qualified System.Random as R+++-- Note: for a UUID to appear in a Kubernetes name, it needs to match this regex+-- [a-z0-9]([-a-z0-9]*[a-z0-9])?(\.[a-z0-9]([-a-z0-9]*[a-z0-9])?)*'+uuidLetters :: [Char]+uuidLetters = ['a'..'z'] ++ ['0'..'9']++numUUIDLetters :: Int+numUUIDLetters = L.length uuidLetters++makeUUID :: MonadIO m => m T.Text+makeUUID = makeUUID' 8++makeUUID' :: MonadIO m => Int -> m T.Text+makeUUID' n = toText <$> (replicateM n ((uuidLetters L.!!) <$> R.randomRIO (0, numUUIDLetters - 1)))
+ lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.Waits where++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.List as L+import qualified Data.Map as M+import Data.String.Interpolate+import Data.Text as T+import Kubernetes.OpenAPI.API.CoreV1 as Kubernetes+import Kubernetes.OpenAPI.Core as Kubernetes+import Kubernetes.OpenAPI.MimeTypes+import Kubernetes.OpenAPI.Model as Kubernetes+import Relude+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Run+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Waits+import UnliftIO.Process+++-- | Wait for a service to have its set of endpoints ready, i.e.:+--+-- * They each have at least one IP address+-- * They each have an empty set of "not ready addresses"+waitForServiceEndpointsToExist :: (+  MonadUnliftIO m, MonadLogger m, MonadMask m+  , MonadReader context m, HasKubernetesClusterContext context+  )+  -- | Namespace+  => Text+  -- | Service name+  -> Text+  -- | Time in seconds to wait+  -> Double+  -> m ()+waitForServiceEndpointsToExist namespace serviceName timeInSeconds = do+  waitUntil timeInSeconds $ do+    endpoints <- listEndpoints namespace mempty+    case Relude.filter v1EndpointsSatisfies endpoints of+      [] -> expectationFailure [i|No endpoints were satisfactory|]+      (x:_) -> do+        debug [i|(#{namespace}) Got satisfactory endpoint for #{serviceName}: #{x}|]+        return ()++  where+    v1EndpointsSatisfies (V1Endpoints {v1EndpointsMetadata=(Just (V1ObjectMeta {v1ObjectMetaName=(Just name)})), v1EndpointsSubsets})+      | name == serviceName = L.all isSatisfactoryV1EndpointSubset (fromMaybe [] v1EndpointsSubsets)+    v1EndpointsSatisfies _ = False++    isSatisfactoryV1EndpointSubset (V1EndpointSubset {+                                       v1EndpointSubsetAddresses=(Just addrs)+                                       , v1EndpointSubsetNotReadyAddresses=(fromMaybe [] -> notReadyAddrs)+                                       }) =+      not (L.null addrs)+      && L.null notReadyAddrs+    isSatisfactoryV1EndpointSubset _ = False+++listEndpoints :: (+  MonadUnliftIO m, MonadLogger m, MonadMask m+  , MonadReader context m, HasKubernetesClusterContext context+  ) => Text -> Map Text Text -> m [V1Endpoints]+listEndpoints namespace labels =+  (v1EndpointsListItems <$>) $ k8sRunException (+      (listNamespacedEndpoints (Accept MimeJSON) (Namespace namespace))+      -&- (LabelSelector (T.intercalate "," [k <> "=" <> v | (k, v) <- M.toList labels]))+    )++-- | Wait for a set of pods to exist, specified by a set of labels.+waitForPodsToExist :: (+  MonadUnliftIO m, MonadLogger m, MonadMask m+  , MonadReader context m, HasKubernetesClusterContext context+  )+  -- | Namespace+  => Text+  -- | Pod labels+  -> Map Text Text+  -- | Time in seconds to wait+  -> Double+  -- | Optional desired pod count to wait for+  -> Maybe Int+  -> m ()+waitForPodsToExist namespace labels timeInSeconds maybeDesiredCount = do+  waitUntil timeInSeconds $ do+    pods <- listPods namespace labels+    case maybeDesiredCount of+      Nothing -> when (L.null pods) $ expectationFailure [i|Found no pods.|]+      Just n -> when (L.length pods /= n) $ expectationFailure [i|Expected #{n} pods, but found #{L.length pods}|]++-- | List the pods matching a set of labels.+listPods :: (+  MonadUnliftIO m, MonadLogger m, MonadMask m+  , MonadReader context m, HasKubernetesClusterContext context+  ) => Text -> Map Text Text -> m [V1Pod]+listPods namespace labels =+  (v1PodListItems <$>) $ k8sRunException (+      (listNamespacedPod (Accept MimeJSON) (Namespace namespace))+      -&- (LabelSelector (T.intercalate "," [k <> "=" <> v | (k, v) <- M.toList labels]))+    )++-- | Wait for a set of pods to be in the Ready condition, specified by a set of labels.+waitForPodsToBeReady :: (+  MonadUnliftIO m, MonadLogger m+  , MonadReader context m, HasKubernetesClusterContext context, HasFile context "kubectl"+  )+  -- | Namespace+  => Text+  -- | Pod labels+  -> Map Text Text+  -- | Time in seconds to wait+  -> Double+  -> m ()+waitForPodsToBeReady namespace labels timeInSeconds = do+  kubectlBinary <- askFile @"kubectl"+  kubeConfigFile <- kubernetesClusterKubeConfigPath <$> getContext kubernetesCluster++  let labelArgs = [[i|-l #{k}=#{v}|] | (k, v) <- M.toList labels]+  p <- createProcessWithLogging (proc kubectlBinary (+                                  ["wait", "pods"+                                  , "--kubeconfig", kubeConfigFile+                                  , "-n", toString namespace+                                  ]+                                  <> labelArgs+                                  <> [+                                    "--for", "condition=Ready"+                                    , "--timeout=" <> show timeInSeconds <> "s"+                                    ]+                                ))+  waitForProcess p >>= \case+    ExitSuccess -> return ()+    ExitFailure n -> expectationFailure [i|Failed to wait for pods to exist (code #{n})|]
+ sandwich-contexts-kubernetes.cabal view
@@ -0,0 +1,137 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           sandwich-contexts-kubernetes+version:        0.1.0.0+synopsis:       Sandwich test contexts for Kubernetes+description:    Please see README.md+author:         Tom McLaughlin+maintainer:     tom@codedown.io+copyright:      2024 Tom McLaughlin+license:        BSD3+build-type:     Simple++library+  exposed-modules:+      Test.Sandwich.Contexts.Kubernetes+      Test.Sandwich.Contexts.Kubernetes.Images+      Test.Sandwich.Contexts.Kubernetes.KataContainers+      Test.Sandwich.Contexts.Kubernetes.KindCluster+      Test.Sandwich.Contexts.Kubernetes.MinikubeCluster+      Test.Sandwich.Contexts.Kubernetes.MinioOperator+      Test.Sandwich.Contexts.Kubernetes.MinioS3Server+      Test.Sandwich.Contexts.Kubernetes.Namespace+      Test.Sandwich.Contexts.Kubernetes.SeaweedFS+  other-modules:+      Test.Sandwich.Contexts.Kubernetes.FindImages+      Test.Sandwich.Contexts.Kubernetes.KindCluster.Config+      Test.Sandwich.Contexts.Kubernetes.KindCluster.Images+      Test.Sandwich.Contexts.Kubernetes.KindCluster.Network+      Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardIngress+      Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardPortForward+      Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup+      Test.Sandwich.Contexts.Kubernetes.Kubectl+      Test.Sandwich.Contexts.Kubernetes.KubectlLogs+      Test.Sandwich.Contexts.Kubernetes.KubectlPortForward+      Test.Sandwich.Contexts.Kubernetes.Longhorn+      Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Forwards+      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.Aeson+      Test.Sandwich.Contexts.Kubernetes.Util.Container+      Test.Sandwich.Contexts.Kubernetes.Util.Exception+      Test.Sandwich.Contexts.Kubernetes.Util.Images+      Test.Sandwich.Contexts.Kubernetes.Util.Nix+      Test.Sandwich.Contexts.Kubernetes.Util.Ports+      Test.Sandwich.Contexts.Kubernetes.Util.SocketUtil+      Test.Sandwich.Contexts.Kubernetes.Util.UUID+      Test.Sandwich.Contexts.Kubernetes.Waits+      Paths_sandwich_contexts_kubernetes+  hs-source-dirs:+      lib+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      LambdaCase+      MultiWayIf+      ViewPatterns+      TupleSections+      FlexibleContexts+      NoImplicitPrelude+      NumericUnderscores+  ghc-options: -Wunused-packages -Wall -Wredundant-constraints+  build-depends:+      aeson+    , base >=4.11 && <5+    , bytestring+    , containers+    , exceptions+    , filepath+    , http-client+    , kubernetes-client+    , kubernetes-client-core+    , lens+    , lens-aeson+    , minio-hs+    , monad-logger+    , network+    , network-uri+    , process+    , random+    , regex-tdfa+    , relude+    , retry+    , safe+    , sandwich+    , sandwich-contexts+    , sandwich-contexts-minio+    , string-interpolate+    , temporary+    , text+    , unliftio+    , unliftio-core+    , vector+    , yaml+  default-language: Haskell2010++test-suite sandwich-contexts-kubernetes-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_sandwich_contexts_kubernetes+  hs-source-dirs:+      test+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      LambdaCase+      MultiWayIf+      ViewPatterns+      TupleSections+      FlexibleContexts+      NoImplicitPrelude+      NumericUnderscores+  ghc-options: -Wunused-packages -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.11 && <5+    , exceptions+    , random+    , relude+    , sandwich+    , sandwich-contexts+    , sandwich-contexts-kubernetes+    , string-interpolate+    , unliftio+    , unliftio-core+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import qualified Data.List as L+import Data.String.Interpolate+import Relude+import System.Exit+import qualified System.Random as R+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes+import Test.Sandwich.Contexts.Kubernetes.Images+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.Waits+import UnliftIO.Exception+import UnliftIO.Process+++spec :: TopSpec+spec = introduceNixContext nixpkgsReleaseDefault $+  introduceBinaryViaNixPackage @"kubectl" "kubectl" $ do+    describe "Minikube" $ introduceMinikubeClusterViaNix defaultMinikubeClusterOptions $+      loadImageTests++    describe "Kind" $ introduceKindClusterViaNix defaultKindClusterOptions $+      loadImageTests++imageLoadSpecs :: [ImageLoadSpec]+imageLoadSpecs = [+  ImageLoadSpecDocker "busybox:latest" IfNotPresent+  , ImageLoadSpecDocker "registry.k8s.io/pause:3.9" IfNotPresent+  , ImageLoadSpecDocker "gcr.io/distroless/static-debian11:latest" IfNotPresent+  ]++tarballDerivations :: [(Text, Text)]+tarballDerivations = [+  ("busybox-tarball", busyboxDerivation)+  ]++imageLabel :: Label "image" Text+imageLabel = Label++imageLoadSpecLabel :: Label "imageLoadSpec" ImageLoadSpec+imageLoadSpecLabel = Label++opts :: NodeOptions+opts = defaultNodeOptions { nodeOptionsVisibilityThreshold = 50 }++loadImageTests :: (+  MonadUnliftIO m, MonadMask m+  , HasBaseContext context, HasKubernetesClusterContext context, HasNixContext context, HasFile context "kubectl"+  ) => SpecFree context m ()+loadImageTests = do+  it "prints the cluster info" $ do+    kcc <- getContext kubernetesCluster+    info [i|Got Kubernetes cluster context: #{kcc}|]++  forM_ tarballDerivations $ \(name, derivation) ->+    introduce' opts [i|#{name}|] imageLoadSpecLabel (ImageLoadSpecTarball <$> buildNixCallPackageDerivation derivation) (const $ return ()) $+    introduce [i|#{name} load (tarball)|] imageLabel (getContext imageLoadSpecLabel >>= loadImage) (const $ return ()) $ do+      loadImageTests'++  forM_ imageLoadSpecs $ \ils ->+    introduce' opts [i|#{ils}|] imageLoadSpecLabel (pure ils) (const $ return ()) $+    introduce [i|#{ils} load|] imageLabel (loadImage ils) (const $ return ()) $ do+      loadImageTests'++loadImageTests' :: (+  MonadUnliftIO m+  , HasBaseContext context+  , HasKubernetesClusterContext context+  , HasFile context "kubectl"+  , HasLabel context "image" Text, HasLabel context "imageLoadSpec" ImageLoadSpec+  ) => SpecFree context m ()+loadImageTests' = do+  it "Doesn't transform Docker/Podman image names" $ do+    image <- getContext imageLabel+    getContext imageLoadSpecLabel >>= \case+      ImageLoadSpecTarball {} -> return ()+      ImageLoadSpecDocker initialImage _ -> image `shouldBe` initialImage+      ImageLoadSpecPodman initialImage _ -> image `shouldBe` initialImage++  it "Cluster contains the image" $ do+    images <- getLoadedImages+    forM_ images $ \img ->+      info [i|loaded image: #{img}|]++    image <- getContext imageLabel+    clusterContainsImage image >>= \case+      False -> expectationFailure [i|Cluster didn't contain image '#{image}'|]+      True -> return ()++  it "Creates a pod and the cluster finds the image already present" $ do+    image <- getContext imageLabel+    podName <- ("test-pod-" <>) <$> randomAlpha 8++    -- namespace <- ("test-namespace-" <>) <$> randomAlpha 8+    -- withKubernetesNamespace' (toText namespace) $+    let namespace = "default"++    (kubectlBinary, env) <- askKubectlArgs++    -- Wait for service account to exist; see+    -- https://github.com/kubernetes/kubernetes/issues/66689+    waitUntil 60 $+      createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace+                                                    , "get", "serviceaccount", "default"+                                                    , "-o", "name"]) { env = Just env })+        >>= waitForProcess >>= (`shouldBe` ExitSuccess)++    let deletePod = createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace+                                                                  , "delete", "pod", podName]) { env = Just env })+                      >>= waitForProcess >>= (`shouldBe` ExitSuccess)++    flip finally deletePod $ do+      createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace+                                                    , "run", podName+                                                    , "--image", toString image+                                                    , "--image-pull-policy=IfNotPresent"+                                                    , "--command", "--", "/bin/sh", "-c", "sleep infinity"+                                                    ]) { env = Just env })+        >>= waitForProcess >>= (`shouldBe` ExitSuccess)++      waitUntil 300 $ do+        events <- readCreateProcessWithLogging ((proc kubectlBinary ["--namespace", namespace+                                                                    , "get", "events"+                                                                    , "--field-selector", [i|involvedObject.kind=Pod,involvedObject.name=#{podName}|]+                                                                    ]) { env = Just env }) ""+        info [i|events: #{events}|]+        events `shouldContain` "already present on machine"++++randomAlpha :: MonadIO m => Int -> m String+randomAlpha len = liftIO $ do+  gen <- R.newStdGen+  return $ L.take len (R.randomRs ('a', 'z') gen)++busyboxDerivation :: Text+busyboxDerivation = [i|+{ dockerTools }:++dockerTools.pullImage {+  imageName = "busybox";+  imageDigest = "sha256:9ae97d36d26566ff84e8893c64a6dc4fe8ca6d1144bf5b87b2b85a32def253c7";+  sha256 = "sha256-S4jXnRLZMZUyxjPku3jczd2PwCsFKR4TXRcIy3C/ym8=";+  finalImageName = "busybox-tarball";+  finalImageTag = "latest";+}+|]++main :: IO ()+main = runSandwichWithCommandLineArgs defaultOptions spec