sandwich-contexts-kubernetes: working on getting kubectl, kubectl-minio from contexts

This commit is contained in:
thomasjm 2024-05-27 02:06:12 -07:00
parent b3eef612aa
commit 0928961b23
10 changed files with 168 additions and 67 deletions

View File

@ -16,6 +16,8 @@ import Test.Sandwich
import Test.Sandwich.Contexts.FakeSmtpServer
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Kubernetes.KindCluster
import Test.Sandwich.Contexts.Kubernetes.MinioOperator
import Test.Sandwich.Contexts.Kubernetes.MinioS3Server
import Test.Sandwich.Contexts.Nix
import Test.Sandwich.Contexts.Waits
@ -31,5 +33,39 @@ spec = describe "Introducing a Kubernetes cluster" $ do
liftIO $ threadDelay 60_000_000
introduceBinaryViaNixPackage @"kubectl" "kubectl" $
introduceBinaryViaNixDerivation @"kubectl-minio" kubectlMinioDerivation $
introduceMinioOperator $ do
it "Has a MinIO operator" $ do
moc <- getContext minioOperator
info [i|Got MinIO operator: #{moc}|]
-- introduceK8SMinioS3Server "foo" $ do
-- Relude.undefined
-- -- it "has a MinIO S3 server" $ do
-- -- Relude.undefined
-- -- -- serv <- getContext testS3Server
-- -- -- info [i|Got test S3 server: #{serv}|]
kubectlMinioDerivation :: Text
kubectlMinioDerivation = [i|
{ fetchurl
}:
fetchurl {
url = "https://github.com/minio/operator/releases/download/v5.0.6/kubectl-minio_5.0.6_linux_amd64";
hash = "sha256-j3mpgV1HLmFwYRdxfPXT1XzDWeiyQC2Ye8aeZt511bc=";
downloadToTemp = true;
executable = true;
postFetch = ''
mkdir -p $out/bin
mv "$downloadedFile" $out/bin/kubectl-minio
'';
}
|]
main :: IO ()
main = runSandwichWithCommandLineArgs defaultOptions spec

View File

@ -1,6 +1,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
module Test.Sandwich.Contexts.Kubernetes.Cluster (
-- * Kind clusters
@ -47,6 +48,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
import Network.URI
import Relude
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Kubernetes.KubectlLogs
import Test.Sandwich.Contexts.Kubernetes.KubectlPortForward
import Test.Sandwich.Contexts.Kubernetes.Types
@ -63,17 +65,18 @@ import qualified Test.Sandwich.Contexts.Kubernetes.Util as Util
withForwardKubernetesService :: (
MonadLoggerIO m, MonadMask m, MonadUnliftIO m, MonadBaseControl IO m
, HasBaseContextMonad context m, HasKubernetesClusterContext context
, HasBaseContextMonad context m, HasKubernetesClusterContext context, HasFile context "kubectl"
) => Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService namespace serviceName action = do
kcc <- getContext kubernetesCluster
withForwardKubernetesService' kcc namespace serviceName action
kubectlBinary <- askFile @"kubectl"
withForwardKubernetesService' kcc kubectlBinary namespace serviceName action
withForwardKubernetesService' :: (
MonadLoggerIO m, MonadMask m, MonadUnliftIO m, MonadBaseControl IO m
, HasBaseContextMonad context m
) => KubernetesClusterContext -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) =
) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) _kubectlBinary =
Minikube.withForwardKubernetesService' kcc minikubeProfileName
withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) =
Kind.withForwardKubernetesService' kcc
withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary =
Kind.withForwardKubernetesService' kcc kubectlBinary

View File

@ -103,7 +103,7 @@ defaultKindClusterOptions = KindClusterOptions {
-- * Introduce
-- | Alias to make type signatures shorter
type KindContext context = LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-kind" (EnvironmentFile "kind") :> context
-- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind binary from the Nix context.

View File

@ -5,7 +5,6 @@
module Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardIngress where
import Test.Sandwich.Contexts.Kubernetes.Types
import Control.Lens
import Control.Lens.Regex.Text
import Control.Monad
@ -24,6 +23,7 @@ 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 UnliftIO.Environment
import UnliftIO.Exception
@ -36,8 +36,8 @@ import UnliftIO.Timeout
withForwardKubernetesService' :: (
MonadUnliftIO m, MonadBaseControl IO m, MonadLoggerIO m
, MonadReader context m
) => KubernetesClusterContext -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) namespace service action = do
) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) kubectlBinary namespace service action = do
baseEnv <- maybe getEnvironment return kindClusterEnvironment
let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
@ -47,9 +47,9 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
let configFile = dir </> "ingress.yaml"
liftIO $ T.writeFile configFile (ingressConfig service randomHost)
createProcessWithLogging ((proc "kubectl" ["create"
, "--namespace", toString namespace
, "-f", configFile]) {
createProcessWithLogging ((proc kubectlBinary ["create"
, "--namespace", toString namespace
, "-f", configFile]) {
env = Just env
}) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
@ -95,7 +95,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{uriToUse}|]
Just x -> pure x
withForwardKubernetesService' _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"
withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"
ingressConfig :: Text -> Text -> Text

View File

@ -1,12 +1,11 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardPortForward where
import Test.Sandwich.Contexts.Kubernetes.Types
import Test.Sandwich.Contexts.Kubernetes.KubectlPortForward
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Unlift
import Control.Monad.Logger
@ -18,6 +17,8 @@ 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
@ -25,13 +26,13 @@ import UnliftIO.Process
withForwardKubernetesService' :: (
MonadUnliftIO m, MonadCatch m, MonadBaseControl IO m, MonadLoggerIO m
, HasBaseContextMonad context m
) => KubernetesClusterContext -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) namespace service action = do
) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) kubectlBinary namespace service action = do
baseEnv <- maybe getEnvironment return kindClusterEnvironment
let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
portRaw <- (toString . T.strip . toText) <$> readCreateProcessWithLogging (
(proc "kubectl" [
(proc kubectlBinary [
"get"
, "service", toString service
, "--namespace", toString namespace
@ -42,7 +43,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
Just p -> pure p
Nothing -> expectationFailure [i|Failed to parse service port: #{portRaw}|]
withKubectlPortForward kubernetesClusterKubeConfigPath namespace ("svc/" <> service) port $ \(KubectlPortForwardContext {..}) -> do
withKubectlPortForward' kubectlBinary kubernetesClusterKubeConfigPath namespace (const True) Nothing ("svc/" <> service) port $ \(KubectlPortForwardContext {..}) -> do
action $ nullURI {
uriScheme = "http:"
, uriAuthority = Just (nullURIAuth {
@ -51,4 +52,4 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
})
}
withForwardKubernetesService' _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"
withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"

View File

@ -1,3 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
module Test.Sandwich.Contexts.Kubernetes.KubectlPortForward (
KubectlPortForwardContext (..)
@ -6,8 +8,6 @@ module Test.Sandwich.Contexts.Kubernetes.KubectlPortForward (
, withKubectlPortForward'
) where
import Test.Sandwich.Contexts.Kubernetes.Util.Ports
import Test.Sandwich.Contexts.Kubernetes.Util.SocketUtil
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Unlift
@ -20,6 +20,9 @@ import Relude hiding (withFile)
import System.FilePath
import System.Process (getPid)
import Test.Sandwich
import Test.Sandwich.Contexts.Files
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
@ -37,16 +40,20 @@ newtype KubectlPortForwardContext = KubectlPortForwardContext {
-- * Implementation
withKubectlPortForward :: (
HasCallStack, HasBaseContextMonad ctx m, MonadCatch m, MonadLogger m, MonadUnliftIO m
HasCallStack, MonadCatch m, MonadLogger m, MonadUnliftIO m
, HasBaseContextMonad ctx m, HasFile ctx "kubectl"
) => FilePath -> Text -> Text -> PortNumber -> (KubectlPortForwardContext -> m a) -> m a
withKubectlPortForward kubeConfigFile namespace = withKubectlPortForward' kubeConfigFile namespace (const True) Nothing
withKubectlPortForward kubeConfigFile namespace targetName targetPort action = do
kubectlBinary <- askFile @"kubectl"
withKubectlPortForward' kubectlBinary kubeConfigFile namespace (const True) Nothing targetName targetPort action
-- | 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 forwarding
withKubectlPortForward' :: (
HasCallStack, HasBaseContextMonad ctx m, MonadCatch m, MonadLogger m, MonadUnliftIO m
) => FilePath -> Text -> (PortNumber -> Bool) -> Maybe PortNumber -> Text -> PortNumber -> (KubectlPortForwardContext -> m a) -> m a
withKubectlPortForward' kubeConfigFile namespace isAcceptablePort maybeHostPort targetName targetPort action = do
HasCallStack, MonadCatch m, MonadLogger m, MonadUnliftIO m
, HasBaseContextMonad ctx m
) => FilePath -> FilePath -> Text -> (PortNumber -> Bool) -> Maybe PortNumber -> Text -> 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}|]
@ -65,10 +72,11 @@ withKubectlPortForward' kubeConfigFile namespace isAcceptablePort maybeHostPort
withFile logPath WriteMode $ \h -> do
let restarterThread = forever $ do
bracket (createProcess ((proc "kubectl" args) { std_out = UseHandle h
, std_err = UseHandle h
, create_group = True
}))
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

View File

@ -13,6 +13,7 @@ module Test.Sandwich.Contexts.Kubernetes.MinioOperator (
, withMinioOperator'
-- * Types
, minioOperator
, MinioOperatorContext(..)
, HasMinioOperatorContext
) where

View File

@ -1,16 +1,23 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Test.Sandwich.Contexts.Kubernetes.MinioS3Server (
introduceK8SMinioS3Server
, introduceK8SMinioS3Server'
, withK8SMinioS3Server
, withK8SMinioS3Server'
-- * Re-exports
, testS3Server
, TestS3Server(..)
, HasTestS3Server
) where
import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString.Base64 as B64
import qualified Data.List as L
import Data.String.Interpolate
@ -19,6 +26,7 @@ import Network.Minio
import Relude
import System.Exit
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Kubernetes.Cluster
import Test.Sandwich.Contexts.Kubernetes.MinioS3Server.Parsing
import Test.Sandwich.Contexts.Kubernetes.Types
@ -30,48 +38,78 @@ import UnliftIO.Exception
import UnliftIO.Process
-- | Introduce a MinIO server on a Kubernetes cluster.
-- Must have a 'minioOperator' context.
introduceK8SMinioS3Server :: (
HasBaseContext context, MonadMask m, MonadBaseControl IO m, MonadUnliftIO m, HasMinioOperatorContext context
MonadMask m, MonadUnliftIO m
, HasBaseContextMonad context m, HasMinioOperatorContext context, HasKubernetesClusterContext context
, HasFile context "kubectl", HasFile context "kubectl-minio"
) => Text -> SpecFree (LabelValue "testS3Server" TestS3Server :> context) m () -> SpecFree context m ()
introduceK8SMinioS3Server namespace = do
introduceWith "minio S3 server" testS3Server $ \action -> do
kcc <- getContext kubernetesCluster
moc <- getContext minioOperator
withK8SMinioS3Server kcc moc namespace action
-- | Same as 'introduceK8SMinioS3Server', but allows you to pass in the 'KubernetesClusterContext'.
introduceK8SMinioS3Server' :: (
MonadMask m, MonadUnliftIO m
, HasBaseContextMonad context m, HasMinioOperatorContext context, HasFile context "kubectl", HasFile context "kubectl-minio"
) => KubernetesClusterContext -> Text -> SpecFree (LabelValue "testS3Server" TestS3Server :> context) m () -> SpecFree context m ()
introduceK8SMinioS3Server kubernetesClusterContext namespace =
introduceK8SMinioS3Server' kubernetesClusterContext namespace =
introduceWith "minio S3 server" testS3Server $ \action -> do
moc <- getContext minioOperator
withK8SMinioS3Server kubernetesClusterContext moc namespace action
-- | Bracket-style variant of 'introduceK8SMinioS3Server'.
withK8SMinioS3Server :: (
MonadLoggerIO m, MonadMask m, MonadBaseControl IO m, MonadUnliftIO m, MonadFail m
, HasBaseContextMonad context m
MonadLoggerIO m, MonadMask m, MonadUnliftIO m, MonadFail m
, HasBaseContextMonad context m, HasFile context "kubectl", HasFile context "kubectl-minio"
) => KubernetesClusterContext -> MinioOperatorContext -> Text -> (TestS3Server -> m [Result]) -> m ()
withK8SMinioS3Server (KubernetesClusterContext {..}) MinioOperatorContext namespace action = do
withK8SMinioS3Server kcc moc namespace action = do
kubectlBinary <- askFile @"kubectl"
kubectlMinioBinary <- askFile @"kubectl-minio"
withK8SMinioS3Server' kubectlBinary kubectlMinioBinary kcc moc namespace action
withK8SMinioS3Server' :: (
MonadLoggerIO m, MonadMask m, MonadUnliftIO m, MonadFail m
, HasBaseContextMonad context m
) => FilePath -> FilePath -> KubernetesClusterContext -> MinioOperatorContext -> Text -> (TestS3Server -> m [Result]) -> m ()
withK8SMinioS3Server' kubectlBinary kubectlMinioBinary (KubernetesClusterContext {..}) MinioOperatorContext namespace action = do
baseEnv <- getEnvironment
let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
let runWithKubeConfig cmd = do
p <- createProcessWithLogging ((shell cmd) { env = Just env, delegate_ctlc = True })
let runWithKubeConfig prog args = do
p <- createProcessWithLogging ((proc prog args) { env = Just env, delegate_ctlc = True })
waitForProcess p >>= (`shouldBe` ExitSuccess)
deploymentName <- ("minio-" <>) <$> makeUUID' 5
let pool = "pool1" :: Text
let pool = "pool1"
let port = 80
let create = do
runWithKubeConfig [iii|kubectl minio tenant create #{deploymentName}
--namespace #{namespace}
--servers 1
--volumes 1
--capacity 10G
--pool #{pool}
--disable-tls
|]
runWithKubeConfig kubectlMinioBinary [
"tenant", "create", toString deploymentName
, "--namespace", toString namespace
, "--servers", "1"
, "--volumes", "1"
, "--capacity", "10G"
, "--pool", pool
, "--disable-tls"
]
let destroy = do
runWithKubeConfig [i|kubectl minio tenant delete #{deploymentName} --namespace #{namespace} -f|]
runWithKubeConfig kubectlMinioBinary ["tenant", "delete", toString deploymentName
, "--namespace", toString namespace
, "-f"
]
bracket_ create destroy $ do
Right envConfig <- ((B64.decode . encodeUtf8 . T.strip . toText) <$>) $
readCreateProcess ((shell [iii|kubectl get secret #{deploymentName}-env-configuration
--namespace #{namespace}
-o jsonpath="{.data.config\\.env}"|]) { env = Just env }) ""
readCreateProcess ((proc kubectlBinary ["get", "secret", [i|#{deploymentName}-env-configuration|]
, "--namespace", toString namespace
, "-o", [i|jsonpath="{.data.config\\.env}"|]
]) { env = Just env }) ""
info [i|Got envConfig: #{envConfig}|]
Just (username, password) <- return (parseMinioUserAndPassword (decodeUtf8 envConfig))
@ -79,7 +117,7 @@ withK8SMinioS3Server (KubernetesClusterContext {..}) MinioOperatorContext namesp
do
uuid <- makeUUID
p <- createProcessWithLogging ((proc "kubectl" [
p <- createProcessWithLogging ((proc kubectlBinary [
"run", "discoverer-" <> toString uuid
, "--rm", "-i"
, "--attach"
@ -96,7 +134,7 @@ withK8SMinioS3Server (KubernetesClusterContext {..}) MinioOperatorContext namesp
export KUBECONFIG=#{kubernetesClusterKubeConfigPath}
kubectl --namespace #{namespace} port-forward "service/minio" 8080:#{port}|]
withKubectlPortForward kubernetesClusterKubeConfigPath namespace "service/minio" port $ \(KubectlPortForwardContext {..}) -> do
withKubectlPortForward' kubectlBinary kubernetesClusterKubeConfigPath namespace (const True) Nothing "service/minio" port $ \(KubectlPortForwardContext {..}) -> do
info [i|Did forward to localhost:#{kubectlPortForwardPort}|]
-- liftIO $ threadDelay 999999999999
@ -118,15 +156,3 @@ withK8SMinioS3Server (KubernetesClusterContext {..}) MinioOperatorContext namesp
waitUntilStatusCodeWithTimeout (4, 0, 3) (1_000_000 * 60 * 5) NoVerify (toString (testS3ServerEndpoint testServ))
void $ action testServ
-- main :: IO ()
-- main = do
-- runSandwichWithCommandLineArgs defaultOptions $ do
-- introduceK8SMinioS3Server $ do
-- it "spins up a demo minio server" $ do
-- fss <- getContext testS3Server
-- info [i|Got test S3 server: #{fss}|]
-- it "waits forever" $ do
-- forever (threadDelay maxBound)

View File

@ -83,3 +83,16 @@ extra-deps:
- git: https://github.com/codedownio/haskell-oidc-client
# codedown-jan-2024-ghc96
commit: 4c122412e80c45bd28d03ead16f1a153bd53fcf4
# https://github.com/kubernetes-client/haskell/issues/64
# https://github.com/channable/vaultenv/issues/99
- git: https://github.com/codedownio/hs-certificate
# codedown-feb-2024
# This branch
# 1. Takes akshaymankar's fixes from https://github.com/haskell-tls/hs-certificate/pull/113
# and rebases them on the most recent https://github.com/haskell-tls/hs-certificate master branch
# 2. Cherry-picks kazuyamamoto's commit switching the package tocrypton, from here:
# https://github.com/kazu-yamamoto/crypton-certificate/commit/c11bbbeec2360ce797c5eb3bd4953cbc5bf1a0d6
commit: dcd0d5b200e96e90c6daa728585c23be5309a955
subdirs:
- x509-validation

View File

@ -70,6 +70,19 @@ packages:
original:
commit: 4c122412e80c45bd28d03ead16f1a153bd53fcf4
git: https://github.com/codedownio/haskell-oidc-client
- completed:
commit: dcd0d5b200e96e90c6daa728585c23be5309a955
git: https://github.com/codedownio/hs-certificate
name: crypton-x509-validation
pantry-tree:
sha256: a33d18d3ebc3011afac3a2fb39b1492b3c4687d332eb33ffcb4557bced4ce8a6
size: 639
subdir: x509-validation
version: 1.6.12
original:
commit: dcd0d5b200e96e90c6daa728585c23be5309a955
git: https://github.com/codedownio/hs-certificate
subdir: x509-validation
snapshots:
- completed:
sha256: e2c529ccfb21501f98f639e056cbde50470b86256d9849d7a82d414ca23e4276