packages feed

sandwich-contexts-kubernetes 0.1.0.0 → 0.1.1.0

raw patch · 14 files changed

+89/−82 lines, 14 filesdep +kubernetes-apidep +kubernetes-api-clientdep −kubernetes-clientdep −kubernetes-client-core

Dependencies added: kubernetes-api, kubernetes-api-client

Dependencies removed: kubernetes-client, kubernetes-client-core

Files

lib/Test/Sandwich/Contexts/Kubernetes.hs view
@@ -63,7 +63,6 @@   , KubectlBasicWithoutReader   ) where -import Control.Monad.Catch import Control.Monad.IO.Unlift import Control.Monad.Logger import Network.URI@@ -85,7 +84,7 @@  -- | Forward a Kubernetes service, so that it can be reached at a local URI. withForwardKubernetesService :: (-  MonadMask m, KubectlBasic context m+  KubectlBasic context m   )   -- | Namespace   => Text@@ -101,7 +100,7 @@  -- | Same as 'withForwardKubernetesService', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary. withForwardKubernetesService' :: (-  MonadLoggerIO m, MonadMask m, MonadUnliftIO m+  MonadLoggerIO m, MonadUnliftIO m   , HasBaseContextMonad context m   )   -- | Kubernetes cluster context
lib/Test/Sandwich/Contexts/Kubernetes/KataContainers.hs view
@@ -33,7 +33,6 @@  import Control.Lens import Control.Monad-import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import Data.Aeson (FromJSON) import Data.String.Interpolate@@ -98,7 +97,7 @@  -- | Install Kata Containers on the cluster and introduce a 'KataContainersContext'. introduceKataContainers :: (-  MonadMask m, Typeable context, KubernetesClusterBasicWithoutReader context m, HasNixContext context+  Typeable context, KubernetesClusterBasicWithoutReader context m, HasNixContext context   )   -- | Options   => KataContainersOptions@@ -108,7 +107,7 @@  -- | Bracket-style version of 'introduceKataContainers'. withKataContainers :: forall context m a. (-  HasCallStack, Typeable context, MonadFail m, MonadMask m, KubectlBasic context m+  HasCallStack, Typeable context, MonadFail m, KubectlBasic context m   )   -- | Options   => KataContainersOptions@@ -121,7 +120,7 @@  -- | Same as 'withKataContainers', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path. withKataContainers' :: forall context m a. (-  HasCallStack, Typeable context, MonadFail m, MonadMask m, KubernetesBasic context m+  HasCallStack, Typeable context, MonadFail m, KubernetesBasic context m   )   => KubernetesClusterContext   -- | Path to @kubectl@ binary
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs view
@@ -40,7 +40,6 @@   ) where  import Control.Monad-import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.String.Interpolate@@ -116,7 +115,7 @@  -- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the @kind@ and @kubectl@ binaries from the Nix context. introduceKindClusterViaNix :: (-  HasBaseContext context, MonadUnliftIO m, MonadMask m, HasNixContext context+  HasBaseContext context, MonadUnliftIO m, HasNixContext context   )   -- | Options   => KindClusterOptions@@ -131,7 +130,7 @@  -- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the @kind@ and @kubectl@ binaries from the PATH. introduceKindClusterViaEnvironment :: (-  HasBaseContext context, MonadMask m, MonadUnliftIO m+  HasBaseContext context, MonadUnliftIO m   )   -- | Options   => KindClusterOptions@@ -144,7 +143,7 @@  -- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), passing in the @kind@ and @kubectl@ binaries. introduceKindCluster' :: (-  HasBaseContext context, MonadMask m, MonadUnliftIO m+  HasBaseContext context, MonadUnliftIO m   )   -- | Path to kind binary   => FilePath@@ -163,7 +162,7 @@  -- | Bracket-style variant of 'introduceKindCluster''. withKindCluster :: (-  MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m+  MonadLoggerIO m, MonadUnliftIO m, MonadFail m   , HasBaseContextMonad context m, HasFile context "kind", HasFile context "kubectl"   )   -- | Options@@ -177,7 +176,7 @@  -- | Same as 'withKindCluster', but allows you to pass in the paths to the @kind@ and @kubectl@ binaries. withKindCluster' :: (-  MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m+  MonadLoggerIO m, MonadUnliftIO m, MonadFail m   , HasBaseContextMonad context m   )   -- | Path to the kind binary
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs view
@@ -6,12 +6,11 @@  module Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardPortForward where -import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.List as L import Data.String.Interpolate-import Data.Text as T+import qualified Data.Text as T import Network.URI import Relude hiding (withFile) import Safe@@ -23,7 +22,7 @@   withForwardKubernetesService' :: (-  MonadUnliftIO m, MonadCatch 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
lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs view
@@ -10,7 +10,6 @@   ) where  import Control.Monad-import Control.Monad.Catch ( MonadMask) import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.List as L@@ -26,7 +25,7 @@   setUpKindCluster :: (-  MonadLoggerIO m, MonadUnliftIO m, MonadMask m+  MonadLoggerIO m, MonadUnliftIO m   ) => KubernetesClusterContext -> FilePath -> FilePath -> Maybe [(String, String)] -> Text -> m () setUpKindCluster kcc@(KubernetesClusterContext {..}) kindBinary kubectlBinary environmentToUse driver = do   baseEnv <- maybe getEnvironment return environmentToUse
lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs view
@@ -8,7 +8,6 @@   ) where  import Control.Monad-import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Unlift import Control.Retry import Data.String.Interpolate@@ -43,7 +42,7 @@ -- Note that this will stop working if the pod you're talking to goes away (even if you do it against a service). -- If this happens, a rerun of the command is needed to resume port forwarding. withKubectlPortForward :: (-  HasCallStack, MonadCatch m, KubectlBasic context m+  HasCallStack, KubectlBasic context m   )   -- | Path to kubeconfig file   => FilePath@@ -61,7 +60,7 @@  -- | Same as 'withKubectlPortForward', but allows you to pass in the @kubectl@ binary path. withKubectlPortForward' :: (-  HasCallStack, MonadCatch m, KubernetesBasic context m+  HasCallStack, KubernetesBasic context m   )   => FilePath   -- | Path to kubeconfig file@@ -94,7 +93,6 @@   let logPath = dir </> toString (T.replace "/" "_" targetName) <.> "port-forwarding.log"    withFile logPath WriteMode $ \h -> do-     let restarterThread = forever $ do           bracket (createProcess ((proc kubectlBinary args) {                                      std_out = UseHandle h
lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs view
@@ -21,6 +21,7 @@   -- * Types   , MinioS3ServerOptions(..)   , defaultMinioS3ServerOptions+  , NetworkPolicies(..)    -- * Re-exports   , testS3Server@@ -29,7 +30,6 @@   ) where  import Control.Monad-import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import Data.String.Interpolate import Data.Text as T@@ -56,14 +56,22 @@   minioS3ServerNamespace :: Text   , minioS3ServerKustomizationDir :: KustomizationDir   , minioS3ServerPreloadImages :: Bool+  , minioS3ServerNetworkPolicies :: Maybe NetworkPolicies   } defaultMinioS3ServerOptions :: Text -> MinioS3ServerOptions defaultMinioS3ServerOptions namespace = MinioS3ServerOptions {   minioS3ServerNamespace = namespace   , minioS3ServerKustomizationDir = KustomizationDirUrl "https://github.com/minio/operator/examples/kustomization/base?ref=v6.0.1"   , minioS3ServerPreloadImages = True+  , minioS3ServerNetworkPolicies = Nothing   } +data NetworkPolicies = NetworkPolicies {+  networkPoliciesNames :: [String]+  , networkPoliciesAllYaml :: String+  }+  deriving (Show, Eq)+ data KustomizationDir =   -- | URL Kustomize dir to be downloaded   KustomizationDirUrl Text@@ -76,7 +84,7 @@ -- | Introduce a MinIO server on a Kubernetes cluster. -- Must have a 'minioOperator' context. introduceK8SMinioS3Server :: (-  MonadMask m, Typeable context, KubectlBasicWithoutReader context m, HasMinioOperatorContext context+  Typeable context, KubectlBasicWithoutReader context m, HasMinioOperatorContext context   )   -- | Options   => MinioS3ServerOptions@@ -90,7 +98,7 @@  -- | Same as 'introduceK8SMinioS3Server', but allows you to pass in the 'KubernetesClusterContext'. introduceK8SMinioS3Server' :: (-  MonadMask m, Typeable context, KubectlBasic context m, HasMinioOperatorContext context+  Typeable context, KubectlBasic context m, HasMinioOperatorContext context   )   => KubernetesClusterContext   -- | Options@@ -104,7 +112,7 @@  -- | Bracket-style variant of 'introduceK8SMinioS3Server'. withK8SMinioS3Server :: (-  Typeable context, MonadMask m, MonadFail m, KubernetesBasic context m, HasFile context "kubectl"+  Typeable context, MonadFail m, KubernetesBasic context m, HasFile context "kubectl"   )   => KubernetesClusterContext   -> MinioOperatorContext@@ -118,7 +126,7 @@  -- | Same as 'withK8SMinioS3Server', but allows you to pass in the @kubectl@ binary. withK8SMinioS3Server' :: forall m context. (-  Typeable context, MonadMask m, MonadFail m, KubernetesBasic context m+  Typeable context, MonadFail m, KubernetesBasic context m   )   -- | Path to kubectl binary   => FilePath@@ -176,19 +184,19 @@    let destroy (_, finalYaml) = do         info [i|-------------------------- DESTROYING --------------------------|]-        createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString finalYaml)+        createProcessWithLoggingAndStdin ((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 (policyName, discoverPodPolicyName, yaml) = networkPolicy deploymentName+        let NetworkPolicies policyNames yaml = fromMaybe (defaultNetworkPolicies deploymentName) minioS3ServerNetworkPolicies         createProcessWithLoggingAndStdin ((proc kubectlBinary ["create", "--namespace", toString minioS3ServerNamespace, "-f", "-"]) { env = Just env, delegate_ctlc = True }) yaml           >>= waitForProcess >>= (`shouldBe` ExitSuccess)-        pure (policyName, discoverPodPolicyName)-  let destroyNetworkPolicy (policyName, discoverPodPolicyName) = do-        runWithKubeConfig kubectlBinary ["delete", "NetworkPolicy", policyName, "--namespace", toString minioS3ServerNamespace]-        runWithKubeConfig kubectlBinary ["delete", "NetworkPolicy", discoverPodPolicyName, "--namespace", toString minioS3ServerNamespace]+        pure policyNames+  let destroyNetworkPolicy policyNames = do+        forM_ policyNames $ \name ->+          runWithKubeConfig kubectlBinary ["delete", "NetworkPolicy", name, "--namespace", toString minioS3ServerNamespace]    bracket createNetworkPolicy destroyNetworkPolicy $ \_ -> bracket create destroy $ \((username, password), _) -> do     do@@ -237,9 +245,14 @@       void $ action testServ  -networkPolicy :: Text -> (String, String, String)-networkPolicy deploymentName = (policyName, discoverPodPolicyName, yaml)+defaultNetworkPolicies :: Text -> NetworkPolicies+defaultNetworkPolicies deploymentName = NetworkPolicies allPolicyNames yaml   where+    allPolicyNames = [+      policyName+      , discoverPodPolicyName+      ]+     policyName = "minio-allow"     discoverPodPolicyName = "discover-pod-allow"
lib/Test/Sandwich/Contexts/Kubernetes/Run.hs view
@@ -1,29 +1,27 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Sandwich.Contexts.Kubernetes.Run where -import Test.Sandwich.Contexts.Kubernetes.Types import Control.Monad-import Control.Monad.Catch (MonadMask, MonadThrow) import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.ByteString.Lazy.Char8 as BL import Data.String.Interpolate-import Data.Text as T import Kubernetes.OpenAPI.Client as Kubernetes import Kubernetes.OpenAPI.Core as Kubernetes import Kubernetes.OpenAPI.MimeTypes import Network.HTTP.Client import Relude import Test.Sandwich+import Test.Sandwich.Contexts.Kubernetes.Types import UnliftIO.Exception  -type Constraints context m = (MonadIO m, MonadThrow m, MonadUnliftIO m, MonadLogger m, MonadMask m, MonadReader context m)+type Constraints context m = (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadReader context m)  instance Exception MimeError
lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs view
@@ -129,10 +129,13 @@    NixContext {..} <- getContext nixContext -  let cp = proc nixContextNixBinary ["build", "--impure"-                                    , "--extra-experimental-features", "nix-command"-                                    , "--expr", seaweedFsOperatorDerivation-                                    , "--json"]+  let cp = proc nixContextNixBinary [+        "build", "--impure"+        , "--extra-experimental-features", "nix-command"+        , "--expr", seaweedFsOperatorDerivation+        , "--no-link"+        , "--json"+        ]    operatorJson <- withFile "/dev/null" WriteMode $ \hNull ->     readCreateProcess (cp { std_err = UseHandle hNull }) ""
lib/Test/Sandwich/Contexts/Kubernetes/Util/Nix.hs view
@@ -3,18 +3,18 @@   withWritableBinaryCache   ) where -import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.String.Interpolate import Relude import System.FilePath-import System.IO.Temp import Test.Sandwich.Logging import UnliftIO.Directory import UnliftIO.Process+import UnliftIO.Temporary  -withWritableBinaryCache :: (MonadIO m, MonadMask m, MonadLogger m) => Maybe FilePath -> (Maybe FilePath -> m a) -> m a+withWritableBinaryCache :: (MonadUnliftIO m, MonadLogger m) => Maybe FilePath -> (Maybe FilePath -> m a) -> m a withWritableBinaryCache Nothing action = action Nothing withWritableBinaryCache (Just readOnlyPath) action =   withSystemTempDirectory "writable-binary-cache" $ \dir -> do
lib/Test/Sandwich/Contexts/Kubernetes/Util/Ports.hs view
@@ -3,32 +3,34 @@  module Test.Sandwich.Contexts.Kubernetes.Util.Ports where -import Control.Monad.Catch (MonadCatch, catch)+import Control.Monad.IO.Unlift import Control.Retry import Network.Socket import Relude import System.Random (randomRIO)+import UnliftIO.Exception   -- | Find an unused port in a given range findFreePortInRange' :: forall m. (-  MonadIO m, MonadCatch m+  MonadUnliftIO m   ) => RetryPolicy -> (PortNumber, PortNumber) -> [PortNumber] -> m (Maybe PortNumber) findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange')-  where getAcceptableCandidate :: m PortNumber-        getAcceptableCandidate = do-          candidate <- liftIO (fromInteger <$> randomRIO (fromIntegral start, fromIntegral end))-          if | candidate `elem` blacklist -> getAcceptableCandidate-             | otherwise -> return candidate+  where+    getAcceptableCandidate :: m PortNumber+    getAcceptableCandidate = do+      candidate <- liftIO (fromInteger <$> randomRIO (fromIntegral start, fromIntegral end))+      if | candidate `elem` blacklist -> getAcceptableCandidate+         | otherwise -> return candidate -        findFreePortInRange' :: m (Maybe PortNumber)-        findFreePortInRange' = do-          candidate <- getAcceptableCandidate-          isPortFree candidate >>= \case-            False -> return Nothing-            True -> return $ Just candidate+    findFreePortInRange' :: m (Maybe PortNumber)+    findFreePortInRange' = do+      candidate <- getAcceptableCandidate+      isPortFree candidate >>= \case+        False -> return Nothing+        True -> return $ Just candidate -isPortFree :: (MonadIO m, MonadCatch m) => PortNumber -> m Bool+isPortFree :: (MonadUnliftIO m) => PortNumber -> m Bool isPortFree candidate = catch (tryOpenAndClosePort candidate >> return True)                              (\(_ :: SomeException) -> return False) @@ -45,7 +47,7 @@     [] -> error "Couldn't resolve address 127.0.0.1"  findFreePortInRange :: (-  MonadIO m, MonadCatch m+  MonadUnliftIO m   ) => (PortNumber, PortNumber) -> [PortNumber] -> m (Maybe PortNumber) findFreePortInRange = findFreePortInRange' (limitRetries 50) @@ -53,18 +55,18 @@ -- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers -- This works without a timeout since there should always be a port in there somewhere; -- it might be advisable to wrap in a timeout anyway.-findFreePort :: (MonadIO m, MonadCatch m) => m (Maybe PortNumber)+findFreePort :: (MonadUnliftIO m) => m (Maybe PortNumber) findFreePort = findFreePortInRange (49152, 65535) [] -findFreePortOrException :: (MonadIO m, MonadCatch m) => m PortNumber+findFreePortOrException :: (MonadUnliftIO m) => m PortNumber findFreePortOrException = findFreePortOrException' (const True) -findFreePortOrException' :: (MonadIO m, MonadCatch m) => (PortNumber -> Bool) -> m PortNumber+findFreePortOrException' :: (MonadUnliftIO m) => (PortNumber -> Bool) -> m PortNumber findFreePortOrException' isAcceptable = findFreePort >>= \case   Just port     | isAcceptable port -> return port     | otherwise -> findFreePortOrException' isAcceptable   Nothing -> error "Couldn't find free port" -findFreePortNotIn :: (MonadIO m, MonadCatch m) => [PortNumber] -> m (Maybe PortNumber)+findFreePortNotIn :: (MonadUnliftIO m) => [PortNumber] -> m (Maybe PortNumber) findFreePortNotIn = findFreePortInRange (49152, 65535)
lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs view
@@ -1,18 +1,17 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}  module Test.Sandwich.Contexts.Kubernetes.Waits where -import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.List as L import qualified Data.Map as M import Data.String.Interpolate-import Data.Text as T+import qualified Data.Text as T import Kubernetes.OpenAPI.API.CoreV1 as Kubernetes import Kubernetes.OpenAPI.Core as Kubernetes import Kubernetes.OpenAPI.MimeTypes@@ -32,7 +31,7 @@ -- * They each have at least one IP address -- * They each have an empty set of "not ready addresses" waitForServiceEndpointsToExist :: (-  MonadUnliftIO m, MonadLogger m, MonadMask m+  MonadUnliftIO m, MonadLogger m   , MonadReader context m, HasKubernetesClusterContext context   )   -- | Namespace@@ -66,7 +65,7 @@   listEndpoints :: (-  MonadUnliftIO m, MonadLogger m, MonadMask m+  MonadUnliftIO m, MonadLogger m   , MonadReader context m, HasKubernetesClusterContext context   ) => Text -> Map Text Text -> m [V1Endpoints] listEndpoints namespace labels =@@ -77,7 +76,7 @@  -- | Wait for a set of pods to exist, specified by a set of labels. waitForPodsToExist :: (-  MonadUnliftIO m, MonadLogger m, MonadMask m+  MonadUnliftIO m, MonadLogger m   , MonadReader context m, HasKubernetesClusterContext context   )   -- | Namespace@@ -98,7 +97,7 @@  -- | List the pods matching a set of labels. listPods :: (-  MonadUnliftIO m, MonadLogger m, MonadMask m+  MonadUnliftIO m, MonadLogger m   , MonadReader context m, HasKubernetesClusterContext context   ) => Text -> Map Text Text -> m [V1Pod] listPods namespace labels =
sandwich-contexts-kubernetes.cabal view
@@ -1,16 +1,16 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack  name:           sandwich-contexts-kubernetes-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Sandwich test contexts for Kubernetes description:    Please see README.md author:         Tom McLaughlin maintainer:     tom@codedown.io-copyright:      2024 Tom McLaughlin+copyright:      2025 Tom McLaughlin license:        BSD3 build-type:     Simple @@ -76,8 +76,8 @@     , exceptions     , filepath     , http-client-    , kubernetes-client-    , kubernetes-client-core+    , kubernetes-api+    , kubernetes-api-client >=0.6.1.1     , lens     , lens-aeson     , minio-hs
test/Spec.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import qualified Data.List as L import Data.String.Interpolate@@ -49,7 +48,7 @@ opts = defaultNodeOptions { nodeOptionsVisibilityThreshold = 50 }  loadImageTests :: (-  MonadUnliftIO m, MonadMask m+  MonadUnliftIO m   , HasBaseContext context, HasKubernetesClusterContext context, HasNixContext context, HasFile context "kubectl"   ) => SpecFree context m () loadImageTests = do