packages feed

sandwich-contexts-kubernetes 0.1.2.0 → 0.1.3.0

raw patch · 24 files changed

+899/−313 lines, 24 filesdep ~sandwich

Dependency ranges changed: sandwich

Files

lib/Test/Sandwich/Contexts/Kubernetes.hs view
@@ -41,6 +41,7 @@   -- * Forward services   , withForwardKubernetesService   , withForwardKubernetesService'+  , withForwardKubernetesServiceFileLogging'    -- * Logs   , module Test.Sandwich.Contexts.Kubernetes.KubectlLogs@@ -119,3 +120,24 @@   Minikube.withForwardKubernetesService' kcc kubernetesClusterTypeMinikubeProfileName withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary =   Kind.withForwardKubernetesService' kcc kubectlBinary++-- | Same as 'withForwardKubernetesService', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary.+withForwardKubernetesServiceFileLogging' :: (+  MonadLoggerIO 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+withForwardKubernetesServiceFileLogging' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) _kubectlBinary =+  Minikube.withForwardKubernetesServiceFileLogging' kcc kubernetesClusterTypeMinikubeProfileName+withForwardKubernetesServiceFileLogging' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary =+  Kind.withForwardKubernetesServiceFileLogging' kcc kubectlBinary
lib/Test/Sandwich/Contexts/Kubernetes/Images.hs view
@@ -100,7 +100,7 @@  -- | Same as 'clusterContainsImage', but allows you to pass in the 'KubernetesClusterContext'. clusterContainsImage' :: (-  HasCallStack, MonadUnliftIO m, MonadLogger m+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m   )   -- | Cluster context   => KubernetesClusterContext
lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs view
@@ -16,6 +16,7 @@ module Test.Sandwich.Contexts.Kubernetes.KataContainers (   -- * Introduce Kata Containers   introduceKataContainers+  , introduceKataContainers'    -- * Bracket-style versions   , withKataContainers@@ -23,7 +24,7 @@    -- * Types   , KataContainersOptions(..)-  , SourceCheckout(..)+   , defaultKataContainersOptions    , kataContainers@@ -31,83 +32,46 @@   , HasKataContainersContext   ) where -import Control.Lens import Control.Monad 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 qualified Test.Sandwich.Contexts.Kubernetes.KataContainers.HelmChart as HC+import Test.Sandwich.Contexts.Kubernetes.KataContainers.Types 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 kataContainersDeployImage-  , 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 :: (-  Typeable context, KubernetesClusterBasicWithoutReader context m, HasNixContext context+  MonadUnliftIO m, HasBaseContext context, HasKubernetesClusterContext context, HasFile context "helm"   )   -- | Options   => KataContainersOptions   -> SpecFree (ContextWithKataContainers context) m ()   -> SpecFree context m ()-introduceKataContainers options = introduceBinaryViaNixPackage @"kubectl" "kubectl" . introduceWith "introduce KataContainers" kataContainers (void . withKataContainers options)+introduceKataContainers options = introduceWith "introduce KataContainers" kataContainers (void . withKataContainers options) +-- | Same as 'introduceKataContainers', but allows you to pass in the 'KubernetesClusterContext' and binary paths.+introduceKataContainers' :: (+  MonadUnliftIO m, HasBaseContext context+  )+  => KubernetesClusterContext+  -- | Path to @helm@ binary+  -> FilePath+  -- | Options+  -> KataContainersOptions+  -> SpecFree (ContextWithKataContainers context) m ()+  -> SpecFree context m ()+introduceKataContainers' kcc helmBinary options = introduceWith "introduce KataContainers" kataContainers (void . withKataContainers' kcc helmBinary options)+ -- | Bracket-style version of 'introduceKataContainers'. withKataContainers :: forall context m a. (-  HasCallStack, Typeable context, MonadFail m, KubectlBasic context m+  HasCallStack, MonadFail m+  , KubernetesClusterBasic context m, HasFile context "helm"   )   -- | Options   => KataContainersOptions@@ -115,23 +79,24 @@   -> m a withKataContainers options action = do   kcc <- getContext kubernetesCluster-  kubectlBinary <- askFile @"kubectl"-  withKataContainers' kcc kubectlBinary options action+  helmBinary <- askFile @"helm"+  withKataContainers' kcc helmBinary options action --- | Same as 'withKataContainers', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path.+-- | Same as 'withKataContainers', but allows you to pass in the 'KubernetesClusterContext' and binary paths. withKataContainers' :: forall context m a. (-  HasCallStack, Typeable context, MonadFail m, KubernetesBasic context m+  HasCallStack, MonadFail m+  , KubernetesBasic context m   )   => KubernetesClusterContext-  -- | Path to @kubectl@ binary+  -- | Path to @helm@ binary   -> FilePath   -> KataContainersOptions   -> (KataContainersContext -> m a)   -> m a-withKataContainers' kcc@(KubernetesClusterContext {..}) kubectlBinary options@(KataContainersOptions {..}) action = do+withKataContainers' kcc@(KubernetesClusterContext {..}) helmBinary options action = do   -- Preflight checks   case kubernetesClusterType of-    KubernetesClusterKind {} -> expectationFailure [i|Can't install Kata Containers on Kind at present.|]+    KubernetesClusterKind {} -> expectationFailure [i|Can't install Kata Containers on Kind at presenpt.|]     KubernetesClusterMinikube {..} -> do       output <- readCreateProcessWithLogging (proc kubernetesClusterTypeMinikubeBinary [                                                  "--profile", toString kubernetesClusterTypeMinikubeProfileName@@ -142,112 +107,4 @@         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 <- getKubectlEnvironment 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-  debug [i|Applying kata-rbac.yaml|]-  createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString rbacContents)-    >>= waitForProcess >>= (`shouldBe` ExitSuccess)-  debug [i|Applying kata-deploy.yaml|]-  createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString deploymentContents)-    >>= waitForProcess >>= (`shouldBe` ExitSuccess)--  debug [i|Waiting for kata-deploy pod to exist|]-  podName <- waitUntil 600 $ do-    pods <- (T.words . toText) <$> readCreateProcessWithLogging ((-      (proc kubectlBinary ["-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-  debug [i|Applying kata-runtimeClasses.yaml|]-  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)-  debug [i|Labeling nodes with katacontainers.io/kata-runtime=true|]-  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--kataContainersDeployImage :: Text-kataContainersDeployImage = "quay.io/kata-containers/kata-deploy:3.19.1"---- | Checkout of the @kata-containers@ repo. Currently at release 3.19.1.-kataContainersDerivation :: Text-kataContainersDerivation = [__i|{fetchFromGitHub}:--                                fetchFromGitHub {-                                  owner = "kata-containers";-                                  repo = "kata-containers";-                                  rev = "acae4480ac84701d7354e679714cc9d084b37f44";-                                  sha256 = "sha256-h9Jsto2l1NhQEwIQoecT/D+yt/QbGoqqH/l6NNzJOwk=";-                                }-                               |]--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+  HC.withKataContainers' helmBinary kcc options action
+ lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.Contexts.Kubernetes.KataContainers.HelmChart (+  withKataContainers+  , withKataContainers'+  ) where++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.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.KataContainers.Types+import Test.Sandwich.Contexts.Kubernetes.Kubectl+import Test.Sandwich.Contexts.Kubernetes.Types+import UnliftIO.Process+++withKataContainers :: (+  MonadFail m, MonadLoggerIO m, MonadUnliftIO m+  , HasBaseContextMonad context m, HasFile context "helm"+  )+  => KubernetesClusterContext+  -> KataContainersOptions+  -> (KataContainersContext -> m b)+  -> m b+withKataContainers kcc options action = do+  helmBinary <- askFile @"helm"+  withKataContainers' helmBinary kcc options action++withKataContainers' :: (+  MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m+  )+  => FilePath+  -> KubernetesClusterContext+  -> KataContainersOptions+  -> (KataContainersContext -> m b)+  -> m b+withKataContainers' helmBinary kcc options@(KataContainersOptions {..}) action = do+  let args = [+        "install", "kata-deploy"+        , kataContainersHelmChart+        , "--namespace", "kube-system"+        , "--wait"+        , "--timeout", "10m", "--atomic"+        -- , "--version", helmChartVersion+        ] <> kataContainersHelmArgs++  info [i|helm #{T.intercalate " " (fmap toText args)}|]++  env <- getKubectlEnvironment kcc++  createProcessWithFileLogging' "helm-install-kata-containers" ((proc helmBinary args) { env = Just env })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  action (KataContainersContext options)
+ lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/Types.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Kubernetes.KataContainers.Types where++import Relude hiding (withFile)+import Test.Sandwich+++data KataContainersContext = KataContainersContext {+  kataContainersOptions :: KataContainersOptions+  } deriving (Show)++data KataContainersOptions =+  KataContainersOptions {+    -- | Path or URL to a Helm chart+    kataContainersHelmChart :: FilePath+    -- | Extra arguments to pass to Helm+    , kataContainersHelmArgs :: [String]+    }+  deriving (Show)++defaultKataContainersOptions :: KataContainersOptions+defaultKataContainersOptions = KataContainersOptions {+  kataContainersHelmChart = "oci://ghcr.io/kata-containers/kata-deploy-charts/kata-deploy:3.23.0"+  , kataContainersHelmArgs = []+  }++kataContainers :: Label "kataContainers" KataContainersContext+kataContainers = Label+type HasKataContainersContext context = HasLabel context "kataContainers" KataContainersContext++type ContextWithKataContainers context =+  LabelValue "kataContainers" KataContainersContext+  :> context
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs view
@@ -216,9 +216,10 @@    (bracket (startKindCluster kindBinary opts clusterName kindConfigFile kindKubeConfigFile environmentToUse driver)            (\_ -> do-               ps <- createProcessWithLogging ((proc kindBinary ["delete", "cluster", "--name", toString clusterName]) {-                                                  env = environmentToUse-                                                  })+               ps <- createProcessWithFileLogging' "kind-delete-cluster" (+                 (proc kindBinary ["delete", "cluster", "--name", toString clusterName]) {+                     env = environmentToUse+                     })                void $ waitForProcess ps            ))            (\kcc -> bracket_ (setUpKindCluster kcc kindBinary kubectlBinary environmentToUse driver)@@ -227,15 +228,17 @@            )  startKindCluster :: (-  MonadLoggerIO m, MonadUnliftIO m+  MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context 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-                                     })+  ps <- createProcessWithFileLogging' "kind-create-cluster" (+    (proc kindBinary ["create", "cluster", "-v", "1", "--name", toString clusterName+                     , "--config", kindConfigFile+                     , "--kubeconfig", kindKubeConfigFile]) {+        delegate_ctlc = True+        , env = environmentToUse+        }+    )   void $ waitForProcess ps    whenM isInContainer $
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs view
@@ -30,7 +30,7 @@  -- | Load an image into a Kind cluster. loadImageKind :: (-  HasCallStack, MonadUnliftIO m, MonadLoggerIO m+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m   )   -- | Path to @kind@ binary   => FilePath@@ -63,7 +63,7 @@             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}"|])+              createProcessWithFileLogging' "kind-image-decompress" (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])                 >>= waitForProcess >>= (`shouldBe` ExitSuccess)               imageLoad tarFile               readImageName (toString image)@@ -72,7 +72,7 @@     ImageLoadSpecDocker image pullPolicy -> do       _ <- dockerPullIfNecessary image pullPolicy -      createProcessWithLogging (+      createProcessWithFileLogging' "kind-load-docker-image" (         (shell [i|#{kindBinary} load docker-image #{image} --name #{clusterName}|]) {             env = env             }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)@@ -86,14 +86,14 @@       return image   where     imageLoad tarFile =-      createProcessWithLogging (+      createProcessWithFileLogging' "kind-load-image-archive" (         (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+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m   )   => KubernetesClusterContext   -- | Driver (should be "docker" or "podman")@@ -128,7 +128,7 @@  -- | Test if the Kind cluster contains a given image. clusterContainsImageKind :: (-  HasCallStack, MonadUnliftIO m, MonadLogger m+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m   )   => KubernetesClusterContext   -- | Driver (should be "docker" or "podman")
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs view
@@ -34,7 +34,7 @@   withForwardKubernetesService' :: (-  MonadUnliftIO m, MonadLoggerIO m+  MonadUnliftIO 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@@ -46,11 +46,12 @@     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)+    createProcessWithFileLogging' "kubectl-create-ingress" (+      (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
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs view
@@ -51,3 +51,9 @@       }  withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"++withForwardKubernetesServiceFileLogging' :: (+  MonadUnliftIO m, MonadLoggerIO m+  , HasBaseContextMonad context m+  ) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a+withForwardKubernetesServiceFileLogging' = withForwardKubernetesService'
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs view
@@ -25,12 +25,12 @@   setUpKindCluster :: (-  MonadLoggerIO m, MonadUnliftIO m+  MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context 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 })+  let runWithKubeConfig cmd = createProcessWithFileLogging' "kind-setup" ((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|]
lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs view
@@ -22,7 +22,7 @@ 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.Concurrent import UnliftIO.Directory import UnliftIO.Exception import UnliftIO.IO@@ -99,7 +99,7 @@                                      , std_err = UseHandle h                                      , create_group = True                                      }))-                  (\(_, _, _, ps) -> gracefullyStopProcess ps 30000000)+                  (\(_, _, _, ps) -> gracefullyStopProcess ps 30_000_000)                   (\(_, _, _, ps) -> do                       pid <- liftIO $ getPid ps                       info [i|Got pid for kubectl port forward: #{pid}|]@@ -107,8 +107,9 @@                       code <- waitForProcess ps                       warn [i|kubectl port-forward #{targetName} #{port}:#{targetPort} exited with code: #{code}. Restarting...|]                   )+          threadDelay 1_000_000  -- 1 second delay between restarts to ensure we don't spin here -    withAsync restarterThread $ \_ -> do+    managedWithAsync_ "kubectl-port-forward-restarter" restarterThread $ do       let policy = constantDelay 100000 <> limitRetries 100       void $ liftIO $ retrying policy (\_ ret -> return ret) $ \_ -> do         not <$> isPortOpen (simpleSockAddr (127, 0, 0, 1) port)
lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs view
@@ -71,14 +71,14 @@   kubectlBinary <- askFile @"kubectl"   withLonghorn' kcc kubectlBinary options action -withLonghorn' :: forall m a. (-  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m+withLonghorn' :: forall context m a. (+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context 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 })+  createProcessWithFileLogging' "longhorn-kubectl-apply" ((proc kubectlBinary ["apply", "-f", longhornYaml]) { env = Just env })     >>= waitForProcess >>= (`shouldBe` ExitSuccess)    action $ LonghornContext options
lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs view
@@ -11,21 +11,24 @@ import qualified Data.List as L import Data.String.Interpolate import Data.Text as T+import qualified Data.Text.IO as T import Network.URI import Relude hiding (withFile)-import System.IO (hGetLine)+import System.FilePath+import System.IO (hClose, hGetLine, openTempFile) import System.Process (getPid) import Test.Sandwich import Test.Sandwich.Contexts.Kubernetes.Types+ import Test.Sandwich.Util.Process-import UnliftIO.Async+import UnliftIO.Concurrent (threadDelay) import UnliftIO.Environment import UnliftIO.Exception import UnliftIO.Process   withForwardKubernetesService' :: (-  HasCallStack, MonadLoggerIO m, MonadUnliftIO m+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m   ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) profile namespace service action = do   baseEnv <- liftIO getEnvironment@@ -47,11 +50,13 @@   (stdoutRead, stdoutWrite) <- liftIO createPipe   (stderrRead, stderrWrite) <- liftIO createPipe -  let forwardStderr = forever $ do-        line <- liftIO $ hGetLine stderrRead-        info [i|minikube service stderr: #{line}|]+  let forwardStderr =+        flip withException (\(e :: SomeException) -> debug [i|withForwardKubernetesService: stderr reader exited due to exception: #{e}|]) $+        forever $ do+          line <- liftIO $ hGetLine stderrRead+          info [i|minikube service stderr: #{line}|] -  withAsync forwardStderr $ \_ -> do+  managedWithAsync_ "minikube-service-stderr" forwardStderr $ do     let cp = (proc kubernetesClusterTypeMinikubeBinary args) {           env = Just env           , std_out = UseHandle stdoutWrite@@ -71,5 +76,59 @@       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"++withForwardKubernetesServiceFileLogging' :: (+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m+  ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a+withForwardKubernetesServiceFileLogging' (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}|]++  let cp = (proc kubernetesClusterTypeMinikubeBinary args) {+        env = Just env+        , create_group = True+        }++  let fileName = namespace <> "-" <> "service"++  getCurrentFolder >>= \case+    Nothing -> expectationFailure [i|withForwardKubernetesServiceFileLogging': no current folder.|]+    Just dir ->+      bracket (liftIO $ openTempFile dir (toString fileName <.> "out")) (\(_outFile, hOut) -> liftIO $ hClose hOut) $ \(outFile, hOut) ->+      bracket (liftIO $ openTempFile dir (toString fileName <.> "err")) (\(_errFile, hErr) -> liftIO $ hClose hErr) $ \(_errFile, hErr) -> do+        let stop (_, _, _, p) = liftIO (getPid p) >>= \case+              Nothing -> return ()+              Just _pid -> gracefullyStopProcess p 120_000_000++        bracket (createProcess (cp { std_out = UseHandle hOut, std_err = UseHandle hErr })) stop $ \_ -> do+          raw <- readFirstLine outFile++          info [i|withForwardKubernetesServiceFileLogging': (#{namespace}) #{service} -> #{raw}|]++          action =<< case parseURI (toString (T.strip raw)) of+            Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesServiceFileLogging': #{raw}|]+            Just x -> pure x+  where+    readFirstLine :: MonadIO m => FilePath -> m Text+    readFirstLine fp = liftIO loop+      where+        loop = do+          contents <- T.readFile fp+          case T.lines contents of+            (x:_) -> pure x+            [] -> threadDelay 50_000 >> loop+withForwardKubernetesServiceFileLogging' _ _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"
lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs view
@@ -25,14 +25,16 @@ import Test.Sandwich.Contexts.Kubernetes.Types import Test.Sandwich.Contexts.Kubernetes.Util.Images import Text.Regex.TDFA+import UnliftIO.Async import UnliftIO.Directory+import UnliftIO.Exception 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+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m   )   -- | Path to @minikube@ binary   => FilePath@@ -58,7 +60,8 @@             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)+              >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))+                                        (cancel asy)             imageLoad tarFile False             readImageName (toString image)         False -> case takeExtension (toString image) of@@ -68,9 +71,10 @@           ".gz" -> do             withSystemTempDirectory "image-tarball" $ \tempDir -> do               let tarFile = tempDir </> "image.tar"-              -- TODO: don't depend on external gzip file+              -- TODO: don't depend on external gzip binary               createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])-                >>= waitForProcess >>= (`shouldBe` ExitSuccess)+                >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))+                                          (cancel asy)               imageLoad tarFile False               readImageName (toString image)           _ -> expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]@@ -84,7 +88,7 @@       imageLoad (toString image) True >> return image    where-    imageLoad :: (MonadLoggerIO m, HasCallStack) => String -> Bool -> m ()+    imageLoad :: (MonadLoggerIO m, HasBaseContextMonad context m, HasCallStack) => String -> Bool -> m ()     imageLoad toLoad daemon = do       let extraFlags = case "--rootless" `L.elem` minikubeFlags of                          True -> ["--rootless"]@@ -100,14 +104,16 @@        -- Gather stderr output while also logging it       logFn <- askLoggerIO+      ctx <- ask       stderrOutputVar <- newIORef mempty       let customLogFn loc src level str = do             modifyIORef' stderrOutputVar (<> str)             logFn loc src level str -      liftIO $ flip runLoggingT customLogFn $+      liftIO $ flip runLoggingT customLogFn $ flip runReaderT ctx $         createProcessWithLogging (proc minikubeBinary args)-          >>= waitForProcess >>= (`shouldBe` ExitSuccess)+          >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))+                                    (cancel asy)        stderrOutput <- fromLogStr <$> readIORef stderrOutputVar @@ -132,7 +138,7 @@  -- | Get the loaded images on a cluster, by cluster name. getLoadedImagesMinikube :: (-  MonadUnliftIO m, MonadLogger m+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m   )   -- | Path to @minikube@ binary   => FilePath@@ -150,7 +156,7 @@  -- | Test if the cluster contains a given image, by cluster name. clusterContainsImageMinikube :: (-  MonadUnliftIO m, MonadLogger m+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m   )   -- | Path to @minikube@ binary   => FilePath
lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs view
@@ -15,16 +15,24 @@ module Test.Sandwich.Contexts.Kubernetes.MinioOperator (   introduceMinioOperator   , introduceMinioOperator'+  , introduceMinioOperator''    -- * Bracket-style variants   , withMinioOperator   , withMinioOperator' +  -- * Misc+  , minioRepoDerivation+   -- * Types   , minioOperator   , MinioOperatorContext(..)+   , MinioOperatorOptions(..)   , defaultMinioOperatorOptions++  , MinioOperatorYamlSource(..)+   , HasMinioOperatorContext   ) where @@ -44,6 +52,7 @@ import Test.Sandwich.Contexts.Kubernetes.Images import Test.Sandwich.Contexts.Kubernetes.Kubectl import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Nix import UnliftIO.Exception import UnliftIO.Process @@ -57,15 +66,37 @@  data MinioOperatorOptions = MinioOperatorOptions {   minioOperatorPreloadImages :: Bool+  , minioOperatorExtraImages :: [Text]+  , minioOperatorYamlSource :: MinioOperatorYamlSource   } defaultMinioOperatorOptions :: MinioOperatorOptions defaultMinioOperatorOptions = MinioOperatorOptions {   minioOperatorPreloadImages = True+  , minioOperatorExtraImages = ["quay.io/minio/operator-sidecar:v6.0.0"]+  , minioOperatorYamlSource = MinioOperatorYamlSourceGitHub "github.com/minio/operator?ref=v6.0.1"   } +data MinioOperatorYamlSource =+  MinioOperatorYamlSourceGitHub String+  | MinioOperatorYamlSourceNixDerivation Text+  deriving (Show, Eq)++-- | Sample derivation for fetching the MinIO repo at version 6.0.4.+minioRepoDerivation :: Text+minioRepoDerivation =+  [__i|{ fetchFromGitHub }:++       fetchFromGitHub {+         owner = "minio";+         repo = "operator";+         rev = "c5b838c475609921935bd4f335fdbc4b6846be14";+         sha256 = "sha256-pWxBqfSxpTWylmR+Bz8+4gGlGwAiLY/3RFNU5mcnOPE=";+       }+      |]+ -- | Install the [MinIO Kubernetes operator](https://min.io/docs/minio/kubernetes/upstream/operations/installation.html) onto a Kubernetes cluster. introduceMinioOperator :: (-  KubectlBasicWithoutReader context m+  Typeable context, KubectlBasicWithoutReader context m   )   -- | Options   => MinioOperatorOptions@@ -73,11 +104,12 @@   -> SpecFree context m () introduceMinioOperator options = introduceWith "introduce MinIO operator" minioOperator $ \action -> do   kcc <- getContext kubernetesCluster-  void $ withMinioOperator options kcc action+  void $ withMinioOperator kcc options action  -- | Same as 'introduceMinioOperator', but allows you to pass in the @kubectl@ binary path. introduceMinioOperator' :: (-  HasCallStack, MonadFail m, MonadUnliftIO m, HasKubernetesClusterContext context, HasBaseContext context+  HasCallStack, MonadFail m, MonadUnliftIO m+  , Typeable context, HasBaseContext context, HasKubernetesClusterContext context   )   -- | Path to @kubectl@ binary   => FilePath@@ -87,44 +119,94 @@   -> SpecFree context m () introduceMinioOperator' kubectlBinary options = introduceWith "introduce MinIO operator" minioOperator $ \action -> do   kcc <- getContext kubernetesCluster-  void $ withMinioOperator' kubectlBinary options kcc action+  void $ withMinioOperator' kubectlBinary kcc options action +-- | Same as 'introduceMinioOperator'', but allows you to pass in the options individually.+introduceMinioOperator'' :: (+  HasCallStack, MonadFail m, MonadUnliftIO m+  , HasBaseContext context, HasKubernetesClusterContext context+  )+  -- | Path to @kubectl@ binary+  => FilePath+  -- | Whether to preload images found in the operator YAML+  -> Bool+  -- | Extra images to preload+  -> [Text]+  -- | Operator YAML+  -> Text+  -> SpecFree (LabelValue "minioOperator" MinioOperatorContext :> context) m ()+  -> SpecFree context m ()+introduceMinioOperator'' kubectlBinary preloadImages extraImages allYaml = introduceWith "introduce MinIO operator" minioOperator $ \action -> do+  kcc <- getContext kubernetesCluster+  void $ withMinioOperator'' kubectlBinary kcc preloadImages extraImages allYaml action+ -- | Bracket-style variant of 'introduceMinioOperator'. withMinioOperator :: (-  HasCallStack, MonadFail m, KubectlBasic context m+  HasCallStack, MonadFail m, Typeable context, KubectlBasic context m   )   -- | Options-  => MinioOperatorOptions-  -> KubernetesClusterContext+  => KubernetesClusterContext+  -> MinioOperatorOptions   -> (MinioOperatorContext -> m a)   -> m a-withMinioOperator options kcc action = do+withMinioOperator kcc options action = do   kubectlBinary <- askFile @"kubectl"-  withMinioOperator' kubectlBinary options kcc action+  withMinioOperator' kubectlBinary kcc options action  -- | Same as 'withMinioOperator', but allows you to pass in the @kubectl@ binary path. withMinioOperator' :: (-  HasCallStack, MonadFail m, KubernetesBasic context m+  HasCallStack, MonadFail m, Typeable context, KubernetesBasic context m   )   -- | Path to @kubectl@ binary   => FilePath+  -> KubernetesClusterContext   -- | Options   -> MinioOperatorOptions+  -> (MinioOperatorContext -> m a)+  -> m a+withMinioOperator' kubectlBinary kcc opts action = do+  allYaml <- case minioOperatorYamlSource opts of+    MinioOperatorYamlSourceGitHub url -> readCreateProcessWithLogging (proc kubectlBinary ["kustomize", url]) ""+    MinioOperatorYamlSourceNixDerivation derivation ->+      getContextMaybe nixContext >>= \case+        Nothing -> expectationFailure [i|Couldn't find a Nix context to use with MinioOperatorYamlSourceNixDerivation|]+        Just nc -> do+          minioRepo <- buildNixCallPackageDerivation' nc derivation+          readCreateProcessWithLogging (proc kubectlBinary ["kustomize", minioRepo]) ""++  withMinioOperator'' kubectlBinary kcc (minioOperatorPreloadImages opts) (minioOperatorExtraImages opts) (toText allYaml) action++-- | Same as 'withMinioOperator'', but allows you to pass in the options individually.+--+-- If you want to generate this YAML yourself, just run a command like+-- @kubectl kustomize "github.com/minio/operator?ref=v6.0.1"@+withMinioOperator'' :: (+  HasCallStack, MonadFail m, KubernetesBasic context m+  )+  -- | Path to @kubectl@ binary+  => FilePath   -> KubernetesClusterContext+  -- | Whether to preload images found in the operator YAML+  -> Bool+  -- | Extra images to preload+  -> [Text]+  -- | Operator YAML+  -> Text   -> (MinioOperatorContext -> m a)   -> m a-withMinioOperator' kubectlBinary (MinioOperatorOptions {..}) kcc action = do+withMinioOperator'' kubectlBinary kcc preloadImages extraImages allYaml action = do   env <- getKubectlEnvironment kcc -  allYaml <- readCreateProcessWithLogging ((proc kubectlBinary ["kustomize", "github.com/minio/operator?ref=v6.0.1"]) { env = Just env }) ""+  when preloadImages $ do+    let images = findAllImages (toText allYaml) <> extraImages -  when minioOperatorPreloadImages $ do-    let images = findAllImages (toText allYaml)+    info [i|Found images to load from YAML: #{images}|]+    info [i|Had extra images to load: #{extraImages}|]      forM_ images $ \image ->       loadImageIfNecessary' kcc (ImageLoadSpecDocker image IfNotPresent) -  let create = createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) allYaml+  let create = createProcessWithFileLoggingAndStdin' "minio-operator-kubectl-apply" ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString allYaml)                  >>= waitForProcess >>= (`shouldBe` ExitSuccess)    let namespaceToDestroy = fromMaybe "minio-operator" (findNamespace (toText allYaml))@@ -136,10 +218,12 @@         -- 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+        createProcessWithFileLoggingAndStdin' "minio-operator-kubectl-delete" (+          (proc kubectlBinary ["delete", "-f", "-"+                              , "--ignore-not-found", "--wait=false", "--all=true"+                              ]) {+              env = Just env, delegate_ctlc = True+              }) (toString allYaml)           >>= waitForProcess >>= (`shouldBe` ExitSuccess)          -- createProcessWithLogging ((proc kubectlBinary ["delete", "namespace", toString namespaceToDestroy, "-f"]) {
lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs view
@@ -22,6 +22,7 @@   , MinioS3ServerOptions(..)   , defaultMinioS3ServerOptions   , NetworkPolicies(..)+  , KustomizationDir(..)    -- * Re-exports   , testS3Server@@ -139,9 +140,9 @@   -> m () withK8SMinioS3Server' kubectlBinary kcc@(KubernetesClusterContext {..}) MinioOperatorContext (MinioS3ServerOptions {..}) action = do   env <- getKubectlEnvironment kcc-  let runWithKubeConfig :: (HasCallStack) => String -> [String] -> m ()-      runWithKubeConfig prog args = do-        createProcessWithLogging ((proc prog args) { env = Just env, delegate_ctlc = True })+  let runWithKubeConfig :: (HasCallStack) => String -> String -> [String] -> m ()+      runWithKubeConfig name prog args = do+        createProcessWithFileLogging' name ((proc prog args) { env = Just env, delegate_ctlc = True })           >>= waitForProcess >>= (`shouldBe` ExitSuccess)    deploymentName <- ("minio-" <>) <$> makeUUID' 5@@ -178,43 +179,45 @@          info [i|Got username and password: #{(username, password)}|] -        createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString finalYaml)+        createProcessWithFileLoggingAndStdin' "minio-s3-kubectl-apply" ((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 ["delete", "-f", "-"]) { env = Just env }) (toString finalYaml)+        createProcessWithFileLoggingAndStdin' "minio-s3-kubectl-delete" ((proc kubectlBinary ["delete", "-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 NetworkPolicies policyNames yaml = fromMaybe (defaultNetworkPolicies deploymentName) minioS3ServerNetworkPolicies-        createProcessWithLoggingAndStdin ((proc kubectlBinary ["create", "--namespace", toString minioS3ServerNamespace, "-f", "-"]) { env = Just env, delegate_ctlc = True }) yaml+        createProcessWithFileLoggingAndStdin' "minio-s3-kubectl-create-network-policy" ((proc kubectlBinary ["create", "--namespace", toString minioS3ServerNamespace, "-f", "-"]) { env = Just env, delegate_ctlc = True }) yaml           >>= waitForProcess >>= (`shouldBe` ExitSuccess)         pure policyNames   let destroyNetworkPolicy policyNames = do         forM_ policyNames $ \name ->-          runWithKubeConfig kubectlBinary ["delete", "NetworkPolicy", name, "--namespace", toString minioS3ServerNamespace]+          runWithKubeConfig "minio-s3-kubectl-delete-network-policy" kubectlBinary ["delete", "NetworkPolicy", name, "--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 })+      p <- createProcessWithFileLogging' "minio-s3-kubectl-run-discoverer" (+        (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.|]
lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs view
@@ -74,7 +74,7 @@ withKubernetesNamespace'' kubectl namespace =   bracket_ (createKubernetesNamespace' kubectl namespace) (destroyKubernetesNamespace' kubectl False namespace) --- | Same as 'withKubernetesNamespace''', but allows you to pass in the path to the cluster context.+-- | Same as 'withKubernetesNamespace''', but allows you to pass in the cluster context. withKubernetesNamespace''' :: (   KubernetesClusterBasic context m   )@@ -151,7 +151,7 @@ createKubernetesNamespace'' kcc kubectl namespace = do   let args = ["create", "namespace", toString namespace]   env <- getKubectlEnvironment kcc-  createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })+  createProcessWithFileLogging' "kubectl-create-namespace" ((proc kubectl args) { env = Just env, delegate_ctlc = True })     >>= waitForProcess >>= (`shouldBe` ExitSuccess)  -- | Destroy a Kubernetes namespace.@@ -171,5 +171,5 @@   let args = ["delete", "namespace", toString namespace]            <> if force then ["--force"] else []   env <- getKubectlEnvironment kcc-  createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })+  createProcessWithFileLogging' "kubectl-delete-namespace" ((proc kubectl args) { env = Just env, delegate_ctlc = True })     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+ lib/Test/Sandwich/Contexts/Kubernetes/PostgresServer.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++Deploy a PostgreSQL server onto a Kubernetes cluster.++The server is provided as a generic 'PostgresContext' (from @sandwich-contexts@), so that you can+easily run the same tests against both Kubernetes environments and host-level ones.++-}++module Test.Sandwich.Contexts.Kubernetes.PostgresServer (+  introduceK8SPostgresServer+  , introduceK8SPostgresServer'++  -- * Bracket-style variants+  , withK8SPostgresServer+  , withK8SPostgresServer'++  -- * Types+  , PostgresK8SOptions(..)+  , defaultPostgresK8SOptions++  -- * Re-exports+  , postgres+  , PostgresContext(..)+  , NetworkAddress(..)+  ) where++import Control.Monad+import Data.String.Interpolate+import Data.Text as T+import Relude+import System.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes+import Test.Sandwich.Contexts.Kubernetes.Images+import Test.Sandwich.Contexts.Kubernetes.Util.UUID+import Test.Sandwich.Contexts.PostgreSQL+import UnliftIO.Exception+import UnliftIO.Process+import UnliftIO.Timeout+++data PostgresK8SOptions = PostgresK8SOptions {+  postgresK8SNamespace :: Text+  , postgresK8SImage :: Text+  , postgresK8SUsername :: Text+  , postgresK8SPassword :: Text+  , postgresK8SDatabase :: Text+  , postgresK8SPreloadImage :: Bool+  }+defaultPostgresK8SOptions :: Text -> PostgresK8SOptions+defaultPostgresK8SOptions namespace = PostgresK8SOptions {+  postgresK8SNamespace = namespace+  , postgresK8SImage = "docker.io/postgres:15"+  , postgresK8SUsername = "postgres"+  , postgresK8SPassword = "postgres"+  , postgresK8SDatabase = "test"+  , postgresK8SPreloadImage = True+  }++-- | Introduce a PostgreSQL server on a Kubernetes cluster.+introduceK8SPostgresServer :: (+  KubectlBasicWithoutReader context m+  )+  -- | Options+  => PostgresK8SOptions+  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()+  -> SpecFree context m ()+introduceK8SPostgresServer options =+  introduceWith "PostgreSQL on K8S" postgres $ \action -> do+    kcc <- getContext kubernetesCluster+    withK8SPostgresServer kcc options action++-- | Same as 'introduceK8SPostgresServer', but allows you to pass in the 'KubernetesClusterContext'.+introduceK8SPostgresServer' :: (+  KubectlBasic context m+  )+  => KubernetesClusterContext+  -- | Options+  -> PostgresK8SOptions+  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()+  -> SpecFree context m ()+introduceK8SPostgresServer' kcc options =+  introduceWith "PostgreSQL on K8S" postgres $ \action ->+    withK8SPostgresServer kcc options action++-- | Bracket-style variant of 'introduceK8SPostgresServer'.+withK8SPostgresServer :: (+  MonadFail m, KubernetesBasic context m, HasFile context "kubectl"+  )+  => KubernetesClusterContext+  -- | Options+  -> PostgresK8SOptions+  -> (PostgresContext -> m [Result])+  -> m ()+withK8SPostgresServer kcc options action = do+  kubectlBinary <- askFile @"kubectl"+  withK8SPostgresServer' kubectlBinary kcc options action++-- | Same as 'withK8SPostgresServer', but allows you to pass in the @kubectl@ binary.+withK8SPostgresServer' :: forall m context. (+  MonadFail m, KubernetesBasic context m+  )+  -- | Path to kubectl binary+  => FilePath+  -> KubernetesClusterContext+  -- | Options+  -> PostgresK8SOptions+  -> (PostgresContext -> m [Result])+  -> m ()+withK8SPostgresServer' kubectlBinary kcc@(KubernetesClusterContext {..}) (PostgresK8SOptions {..}) action = do+  env <- getKubectlEnvironment kcc++  deploymentName <- ("postgres-" <>) <$> makeUUID' 5++  let postgresPort = 5432 :: Int++  when postgresK8SPreloadImage $ do+    debug [i|Preloading postgres image: #{postgresK8SImage}|]+    loadImageIfNecessary' kcc (ImageLoadSpecDocker postgresK8SImage IfNotPresent)++  let yaml = postgresYaml deploymentName postgresK8SNamespace postgresK8SImage+                          postgresK8SUsername postgresK8SPassword postgresK8SDatabase++  let create = do+        (ps, _) <- createProcessWithLoggingAndStdin+          ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env })+          (toString yaml)+        waitForProcess ps >>= (`shouldBe` ExitSuccess)++  let destroy = do+        info [i|Destroying PostgreSQL K8S resources|]+        (ps, _) <- createProcessWithLoggingAndStdin+          ((proc kubectlBinary ["delete", "-f", "-", "--ignore-not-found"]) { env = Just env })+          (toString yaml)+        waitForProcess ps >>= (`shouldBe` ExitSuccess)++  bracket_ create destroy $ do+    -- Wait for the pod to be ready+    let waitArgs = ["wait", "pod"+                   , "-l", [i|app=#{deploymentName}|]+                   , "--namespace", toString postgresK8SNamespace+                   , "--for", "condition=Ready"+                   , "--timeout=120s"+                   , "--kubeconfig", kubernetesClusterKubeConfigPath+                   ]+    timeout 150_000_000 (do+      (ps, _) <- createProcessWithLogging ((proc kubectlBinary waitArgs) { env = Just env })+      waitForProcess ps >>= (`shouldBe` ExitSuccess)+      ) >>= \case+        Just () -> return ()+        Nothing -> expectationFailure [i|Timed out waiting for PostgreSQL pod to be ready|]++    let serviceName = [i|service/#{deploymentName}|] :: Text+    withKubectlPortForward' kubectlBinary kubernetesClusterKubeConfigPath postgresK8SNamespace+                            (const True) Nothing serviceName (fromIntegral postgresPort) $ \(KubectlPortForwardContext {..}) -> do+      info [i|PostgreSQL port-forwarded to localhost:#{kubectlPortForwardPort}|]++      let ctx = PostgresContext {+            postgresUsername = postgresK8SUsername+            , postgresPassword = postgresK8SPassword+            , postgresDatabase = postgresK8SDatabase+            , postgresAddress = NetworkAddressTCP "localhost" kubectlPortForwardPort+            , postgresConnString = [i|postgresql://#{postgresK8SUsername}:#{postgresK8SPassword}@localhost:#{kubectlPortForwardPort}/#{postgresK8SDatabase}|]+            , postgresContainerAddress = Just $ NetworkAddressTCP (toString deploymentName) (fromIntegral postgresPort)+            }++      void $ action ctx+++postgresYaml :: Text -> Text -> Text -> Text -> Text -> Text -> Text+postgresYaml name namespace image username password database = [__i|+  apiVersion: v1+  kind: Pod+  metadata:+    name: #{name}+    namespace: #{namespace}+    labels:+      app: "#{name}"+  spec:+    containers:+    - name: postgres+      image: "#{image}"+      imagePullPolicy: IfNotPresent+      env:+      - name: POSTGRES_USER+        value: "#{username}"+      - name: POSTGRES_PASSWORD+        value: "#{password}"+      - name: POSTGRES_DB+        value: "#{database}"+      ports:+      - containerPort: 5432+      readinessProbe:+        exec:+          command:+          - pg_isready+          - -U+          - "#{username}"+        initialDelaySeconds: 5+        periodSeconds: 2+  ---+  apiVersion: v1+  kind: Service+  metadata:+    name: #{name}+    namespace: #{namespace}+  spec:+    selector:+      app: "#{name}"+    ports:+    - port: 5432+      targetPort: 5432+  |]
lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs view
@@ -166,7 +166,7 @@     _ <- readCreateProcess (proc "cp" ["-r", toString operatorPath, target]) ""     _ <- readCreateProcess (proc "chmod" ["-R", "u+w", target]) "" -    let runOperatorCmd cmd extraEnv = createProcessWithLogging (+    let runOperatorCmd cmd extraEnv = createProcessWithFileLogging' "seaweedfs-operator" (           (shell cmd) {               env = Just (env <> extraEnv)               , cwd = Just target@@ -193,7 +193,7 @@     info [i|------------------ Creating SeaweedFS deployment ------------------|]      let val = decodeUtf8 $ A.encode $ example namespace options-    createProcessWithLoggingAndStdin ((shell [i|#{kubectlBinary} create -f -|]) { env = Just env }) val+    createProcessWithFileLoggingAndStdin' "seaweedfs-kubectl-create" ((shell [i|#{kubectlBinary} create -f -|]) { env = Just env }) val       >>= waitForProcess >>= (`shouldBe` ExitSuccess)      action $ SeaweedFSContext {
+ lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs view
@@ -0,0 +1,196 @@+{-# 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 [Typesense](https://typesense.org/) on a Kubernetes cluster using Helm.++Typesense is an open-source, typo-tolerant search engine optimized for instant search experiences.++-}++module Test.Sandwich.Contexts.Kubernetes.Typesense (+  -- * Introduce Typesense+  introduceTypesense++  -- * Bracket-style versions+  , withTypesense+  , withTypesense'++  -- * Types+  , TypesenseOptions(..)+  , defaultTypesenseOptions++  , typesense+  , TypesenseContext(..)+  , HasTypesenseContext+  ) 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.Exit+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Kubernetes.Kubectl+import Test.Sandwich.Contexts.Kubernetes.Types+import Test.Sandwich.Contexts.Nix+import UnliftIO.Exception+import UnliftIO.Process+++-- * Types++data TypesenseContext = TypesenseContext {+  typesenseOptions :: TypesenseOptions+  -- | The service name that can be used to connect to Typesense within the cluster+  , typesenseServiceName :: Text+  -- | The namespace where Typesense is installed+  , typesenseNamespace :: Text+  } deriving (Show)++data TypesenseOptions = TypesenseOptions {+  -- | Helm chart to install (repo URL or OCI reference)+  typesenseHelmChart :: Text+  -- | Release name for Helm+  , typesenseReleaseName :: Text+  -- | API key for Typesense authentication+  , typesenseApiKey :: Text+  -- | Number of replicas (for HA setup)+  , typesenseReplicas :: Int+  -- | Storage size for persistence+  , typesenseStorageSize :: Text+  -- | Extra arguments to pass to Helm+  , typesenseHelmArgs :: [String]+  } deriving (Show)++defaultTypesenseOptions :: TypesenseOptions+defaultTypesenseOptions = TypesenseOptions {+  typesenseHelmChart = "springboard/typesense"+  , typesenseReleaseName = "typesense"+  , typesenseApiKey = "xyz"+  , typesenseReplicas = 1+  , typesenseStorageSize = "1Gi"+  , typesenseHelmArgs = []+  }++typesense :: Label "typesense" TypesenseContext+typesense = Label+type HasTypesenseContext context = HasLabel context "typesense" TypesenseContext++type ContextWithTypesense context =+  LabelValue "typesense" TypesenseContext+  :> context+++-- * Introduce++-- | Introduce [Typesense](https://typesense.org/) on the Kubernetes cluster, in a given namespace.+introduceTypesense :: (+  KubernetesClusterBasicWithoutReader context m+  , HasNixContext context+  , HasFile context "kubectl"+  )+  -- | Namespace+  => Text+  -> TypesenseOptions+  -> SpecFree (ContextWithTypesense context) m ()+  -> SpecFree context m ()+introduceTypesense namespace options =+  introduceWith "introduce Typesense" typesense (void . withTypesense namespace options)++-- | Bracket-style version of 'introduceTypesense'.+withTypesense :: forall context m a. (+  HasCallStack, MonadFail m+  , KubectlBasic context m, HasNixContext context+  )+  -- | Namespace+  => Text+  -> TypesenseOptions+  -> (TypesenseContext -> m a)+  -> m a+withTypesense namespace options action = do+  kcc <- getContext kubernetesCluster+  kubectlBinary <- askFile @"kubectl"+  withTypesense' kcc kubectlBinary namespace options action++-- | Same as 'withTypesense', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path.+withTypesense' :: forall context m a. (+  HasCallStack, MonadFail m, NixContextBasic context m+  )+  -- | Cluster context+  => KubernetesClusterContext+  -- | Path to @kubectl@ binary+  -> FilePath+  -- | Namespace+  -> Text+  -> TypesenseOptions+  -> (TypesenseContext -> m a)+  -> m a+withTypesense' kcc _kubectlBinary namespace options@(TypesenseOptions {..}) action = do+  helmBinary <- buildNixSymlinkJoin ["kubernetes-helm"] >>= \p -> return (p <> "/bin/helm")++  env <- getKubectlEnvironment kcc++  -- Add the Helm repository+  info [i|Adding Typesense Helm repository...|]+  createProcessWithFileLogging' "helm-repo-add" ((proc helmBinary [+    "repo", "add", "springboard", "https://helm-charts.springboardvr.com"+    ]) { env = Just env })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  createProcessWithFileLogging' "helm-repo-update" ((proc helmBinary ["repo", "update"]) { env = Just env })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  -- Install Typesense via Helm+  info [i|Installing Typesense via Helm in namespace '#{namespace}'...|]+  let helmArgs = [+        "install", toString typesenseReleaseName+        , toString typesenseHelmChart+        , "--namespace", toString namespace+        , "--create-namespace"+        , "--wait"+        , "--timeout", "5m"+        , "--atomic"+        , "--set", [i|replicas=#{typesenseReplicas}|]+        , "--set", [i|persistence.size=#{typesenseStorageSize}|]+        -- API key must be passed via extraEnv+        , "--set", [i|extraEnv[0].name=TYPESENSE_API_KEY|]+        , "--set", [i|extraEnv[0].value=#{typesenseApiKey}|]+        ] <> typesenseHelmArgs++  info [i|helm #{T.intercalate " " (fmap toText helmArgs)}|]++  createProcessWithFileLogging' "helm-install-typesense" ((proc helmBinary helmArgs) { env = Just env })+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)++  let serviceName = typesenseReleaseName++  info [i|Typesense installed successfully. Service: #{serviceName}|]++  flip finally (cleanupTypesense helmBinary env namespace typesenseReleaseName) $ do+    action $ TypesenseContext {+      typesenseOptions = options+      , typesenseServiceName = serviceName+      , typesenseNamespace = namespace+      }++cleanupTypesense :: (MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m) => FilePath -> [(String, String)] -> Text -> Text -> m ()+cleanupTypesense helmBinary env namespace releaseName = do+  info [i|Cleaning up Typesense release '#{releaseName}' in namespace '#{namespace}'...|]+  createProcessWithFileLogging' "helm-uninstall-typesense" ((proc helmBinary [+    "uninstall", toString releaseName+    , "--namespace", toString namespace+    ]) { env = Just env })+    >>= waitForProcess >>= \case+      ExitSuccess -> info [i|Typesense uninstalled successfully.|]+      ExitFailure n -> warn [i|Failed to uninstall Typesense (exit code #{n})|]
lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs view
@@ -38,25 +38,25 @@  -- | 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 :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> ImagePullPolicy -> m Bool dockerPullIfNecessary = commonPullIfNecessary "docker" -isDockerImagePresent :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> m Bool+isDockerImagePresent :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context 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 :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> ImagePullPolicy -> m Bool podmanPullIfNecessary = commonPullIfNecessary "podman" -isPodmanImagePresent :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> m Bool+isPodmanImagePresent :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> m Bool isPodmanImagePresent = isImagePresentCommon "podman"  -- * Common -commonPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => String -> Text -> ImagePullPolicy -> m Bool+commonPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => String -> Text -> ImagePullPolicy -> m Bool commonPullIfNecessary binary image pullPolicy = isImagePresentCommon binary image >>= \case   True ->     if | pullPolicy == Always -> doPull@@ -66,19 +66,19 @@        | otherwise -> doPull   where     doPull = do-      createProcessWithLogging (proc binary ["pull", toString image])+      createProcessWithFileLogging' (takeFileName binary <> "-pull") (proc binary ["pull", toString image])         >>= waitForProcess >>= (`shouldBe` ExitSuccess)       return True -isImagePresentCommon :: (MonadUnliftIO m, MonadLoggerIO m) => String -> Text -> m Bool+isImagePresentCommon :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => String -> Text -> m Bool isImagePresentCommon binary image = do-  createProcessWithLogging (proc binary ["inspect", "--type=image", toString image]) >>= waitForProcess >>= \case+  createProcessWithFileLogging' (takeFileName binary <> "-inspect") (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 :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => FilePath -> m Text readImageName path = doesDirectoryExist path >>= \case   True -> readUncompressedImageName path   False -> case takeExtension path of@@ -88,17 +88,33 @@   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+      let fileList = T.words (toText files)+      case headMay [t | t <- fileList, "manifest.json" `T.isInfixOf` t] of+        Just manifestFile -> do+          let manifestFileName = toString $ T.strip manifestFile+          withSystemTempDirectory "manifest.json" $ \dir -> do+            _ <- readCreateProcessWithLogging ((proc "tar" ["xvf", path, manifestFileName]) { cwd = Just dir }) ""+            liftIO (BL.readFile (dir </> "manifest.json")) >>= getImageNameFromManifestJson path+        Nothing -> case headMay [t | t <- fileList, "index.json" `T.isInfixOf` t] of+          Just indexFile -> do+            let indexFileName = toString $ T.strip indexFile+            withSystemTempDirectory "index.json" $ \dir -> do+              _ <- readCreateProcessWithLogging ((proc "tar" ["xvf", path, indexFileName]) { cwd = Just dir }) ""+              liftIO (BL.readFile (dir </> "index.json")) >>= getImageNameFromOciIndex path+          Nothing -> expectationFailure [i|readImageName: couldn't find manifest.json or index.json in #{path}|]  readUncompressedImageName :: (HasCallStack, MonadIO m) => FilePath -> m Text-readUncompressedImageName path = liftIO (BL.readFile (path </> "manifest.json")) >>= getImageNameFromManifestJson path+readUncompressedImageName path = do+  let manifestPath = path </> "manifest.json"+  let indexPath = path </> "index.json"+  liftIO (doesFileExist manifestPath) >>= \case+    True -> liftIO (BL.readFile manifestPath) >>= getImageNameFromManifestJson path+    False ->+      liftIO (doesFileExist indexPath) >>= \case+        True -> liftIO (BL.readFile indexPath) >>= getImageNameFromOciIndex path+        False -> expectationFailure [i|readUncompressedImageName: couldn't find manifest.json or index.json in #{path}|] +-- | Read image name from legacy Docker manifest.json getImageNameFromManifestJson :: (HasCallStack, MonadIO m) => FilePath -> LByteString -> m Text getImageNameFromManifestJson path contents = do   case A.eitherDecode contents of@@ -113,7 +129,18 @@     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+-- | Read image name from OCI index.json+getImageNameFromOciIndex :: (HasCallStack, MonadIO m) => FilePath -> LByteString -> m Text+getImageNameFromOciIndex path contents =+  case A.eitherDecode contents of+    Right (A.Object (aesonLookup "manifests" -> Just (A.Array manifests))) ->+      case headMay [name | A.Object (aesonLookup "annotations" -> Just (A.Object (aesonLookup "org.opencontainers.image.ref.name" -> Just (A.String name)))) <- V.toList manifests] of+        Just name -> pure name+        Nothing -> expectationFailure [i|Didn't find org.opencontainers.image.ref.name annotation in OCI index at #{path}|]+    Left err -> expectationFailure [i|Couldn't decode OCI index.json: #{err}|]+    Right x -> expectationFailure [i|Unexpected OCI index.json format: #{x}|]++imageLoadSpecToImageName :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => ImageLoadSpec -> m Text imageLoadSpecToImageName (ImageLoadSpecTarball image) = readImageName image imageLoadSpecToImageName (ImageLoadSpecDocker image _) = pure image imageLoadSpecToImageName (ImageLoadSpecPodman image _) = pure image
lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs view
@@ -109,7 +109,7 @@ -- | 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"+  , MonadReader context m, HasBaseContext context, HasKubernetesClusterContext context, HasFile context "kubectl"   )   -- | Namespace   => Text@@ -123,17 +123,19 @@   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"-                                    ]-                                ))+  p <- createProcessWithFileLogging' "kubectl-wait-pods" (+    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
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           sandwich-contexts-kubernetes-version:        0.1.2.0+version:        0.1.3.0 synopsis:       Sandwich test contexts for Kubernetes description:    Please see README.md author:         Tom McLaughlin@@ -24,9 +24,13 @@       Test.Sandwich.Contexts.Kubernetes.MinioOperator       Test.Sandwich.Contexts.Kubernetes.MinioS3Server       Test.Sandwich.Contexts.Kubernetes.Namespace+      Test.Sandwich.Contexts.Kubernetes.PostgresServer       Test.Sandwich.Contexts.Kubernetes.SeaweedFS+      Test.Sandwich.Contexts.Kubernetes.Typesense   other-modules:       Test.Sandwich.Contexts.Kubernetes.FindImages+      Test.Sandwich.Contexts.Kubernetes.KataContainers.HelmChart+      Test.Sandwich.Contexts.Kubernetes.KataContainers.Types       Test.Sandwich.Contexts.Kubernetes.KindCluster.Config       Test.Sandwich.Contexts.Kubernetes.KindCluster.Images       Test.Sandwich.Contexts.Kubernetes.KindCluster.Network@@ -90,7 +94,7 @@     , relude     , retry     , safe-    , sandwich+    , sandwich >=0.3.1.0     , sandwich-contexts     , sandwich-contexts-minio     , string-interpolate
test/Spec.hs view
@@ -5,7 +5,6 @@ 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@@ -104,23 +103,24 @@     -- 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)+      void $ readCreateProcessWithLogging (+        (proc kubectlBinary ["--namespace", namespace+                            , "get", "serviceaccount", "default"+                            , "-o", "name"]) { env = Just env }+        ) "" -    let deletePod = createProcessWithLogging ((proc kubectlBinary ["--namespace", namespace-                                                                  , "delete", "pod", podName]) { env = Just env })-                      >>= waitForProcess >>= (`shouldBe` ExitSuccess)+    let deletePod = void $ readCreateProcessWithLogging ((proc kubectlBinary ["--namespace", namespace+                                                                             , "delete", "pod", podName]) { env = Just env }) ""      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)+      _ <- readCreateProcessWithLogging (+        (proc kubectlBinary ["--namespace", namespace+                            , "run", podName+                            , "--image", toString image+                            , "--image-pull-policy=IfNotPresent"+                            , "--command", "--", "/bin/sh", "-c", "sleep infinity"+                            ]) { env = Just env }+        ) ""        waitUntil 300 $ do         events <- readCreateProcessWithLogging ((proc kubectlBinary ["--namespace", namespace