sandwich-contexts-kubernetes: progress on haddocks

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Cluster.hs

@@ -17,11 +17,17 @@ module Test.Sandwich.Contexts.Kubernetes.Cluster (
   , Kind.introduceKindClusterViaEnvironment
   , Kind.introduceKindCluster'
 
+  , Kind.defaultKindClusterOptions
+  , Kind.KindClusterOptions(..)
+
   -- * Minikube clusters
   , Minikube.introduceMinikubeClusterViaNix
   , Minikube.introduceMinikubeClusterViaEnvironment
   , Minikube.introduceMinikubeCluster'
 
+  , Minikube.defaultMinikubeClusterOptions
+  , Minikube.MinikubeClusterOptions(..)
+
   -- * Wait for pods/services
   , waitForPodsToExist
   , waitForPodsToBeReady
@@ -46,9 +52,6 @@ module Test.Sandwich.Contexts.Kubernetes.Cluster (
   , kubernetesCluster
   , HasKubernetesClusterContext
 
-  , Minikube.MinikubeClusterOptions(..)
-  , Minikube.defaultMinikubeClusterOptions
-
   -- * Util
   , Util.parseHostnameAndPort
   ) where
@@ -75,9 +78,9 @@ import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Forwards as M
 import qualified Test.Sandwich.Contexts.Kubernetes.Util as Util
 
 
+-- | Forward a Kubernetes service, so that it can be reached at a local URI.
 withForwardKubernetesService :: (
-  MonadLoggerIO m, MonadMask m, MonadUnliftIO m
-  , HasBaseContextMonad context m, HasKubernetesClusterContext context, HasFile context "kubectl"
+  MonadMask m, KubernetesClusterBasic m context
   )
   -- | Namespace
   => Text
@@ -91,6 +94,7 @@ withForwardKubernetesService namespace serviceName action = do
   kubectlBinary <- askFile @"kubectl"
   withForwardKubernetesService' kcc kubectlBinary namespace serviceName action
 
+-- | Same as 'withForwardKubernetesService', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary.
 withForwardKubernetesService' :: (
   MonadLoggerIO m, MonadMask m, MonadUnliftIO m
   , HasBaseContextMonad context m

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs

@@ -37,7 +37,7 @@ import Data.Text as T
 import Relude
 import Test.Sandwich
 import Test.Sandwich.Contexts.Kubernetes.FindImages
-import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster.Images as Kind
+import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster as Kind
 import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images as Minikube
 import Test.Sandwich.Contexts.Kubernetes.Types
 import Test.Sandwich.Contexts.Kubernetes.Util.Images

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs

@@ -13,6 +13,11 @@ module Test.Sandwich.Contexts.Kubernetes.KindCluster (
   , withKindCluster
   , withKindCluster'
 
+  -- * Image management
+  , Images.clusterContainsImage
+  , Images.getLoadedImages
+  , Images.loadImage
+
   -- * Re-exported types
   , KubernetesClusterContext (..)
   , kubernetesCluster
@@ -39,6 +44,7 @@ import System.IO.Temp
 import Test.Sandwich
 import Test.Sandwich.Contexts.Files
 import Test.Sandwich.Contexts.Kubernetes.KindCluster.Config
+import qualified Test.Sandwich.Contexts.Kubernetes.KindCluster.Images as Images
 import Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup
 import Test.Sandwich.Contexts.Kubernetes.Types
 import Test.Sandwich.Contexts.Kubernetes.Util.Container (isInContainer)
@@ -68,7 +74,7 @@ data KindClusterName =
 
 data KindClusterOptions = KindClusterOptions {
   kindClusterNumNodes :: Int
-  -- | Extra flags to pass to kind
+  -- | Extra flags to pass to @kind@
   , kindClusterExtraFlags :: [Text]
   -- | Labels to apply to the created containers
   , kindClusterContainerLabels :: Map Text Text
@@ -78,7 +84,7 @@ data KindClusterOptions = KindClusterOptions {
   , kindClusterExtraMounts :: [ExtraMount]
   -- | Prefix for the generated cluster name
   , kindClusterName :: KindClusterName
-  -- | Container driver, either "docker" or "podman". Defaults to "docker"
+  -- | Container driver, either "docker" or "podman". Defaults to "docker".
   , kindClusterDriver :: Maybe Text
   -- , kindClusterCpus :: Maybe Text
   -- , kindClusterMemory :: Maybe Text
@@ -101,7 +107,7 @@ defaultKindClusterOptions = KindClusterOptions {
 -- | Alias to make type signatures shorter
 type KindContext context = LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> LabelValue "file-kind" (EnvironmentFile "kind") :> context
 
--- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind and kubectl binaries from the Nix context.
+-- | 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
   )
@@ -116,7 +122,7 @@ introduceKindClusterViaNix kindClusterOptions spec =
     introduceBinaryViaNixPackage @"kubectl" "kubectl" $
       introduceWith "introduce kind cluster" kubernetesCluster (void . withKindCluster kindClusterOptions) spec
 
--- | Introduce a Kubernetes cluster using [kind](https://kind.sigs.k8s.io/), deriving the kind and kubectl binaries from the PATH.
+-- | 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
   )

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Kubectl.hs

@@ -25,8 +25,7 @@ import UnliftIO.Environment
 --
 -- Useful for running Kubectl commands with 'System.Process.createProcess' etc.
 askKubectlArgs :: (
-  MonadLoggerIO m
-  , HasBaseContextMonad context m, HasFile context "kubectl", HasKubernetesClusterContext context
+  KubernetesClusterBasic m context
   )
   -- | Returns the @kubectl@ binary and environment variables.
   => m (FilePath, [(String, String)])

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlLogs.hs

@@ -2,8 +2,8 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Sandwich.Contexts.Kubernetes.KubectlLogs (
-  KubectlLogsContext (..)
-  , withKubectlLogs
+  withKubectlLogs
+  , KubectlLogsContext (..)
   ) where
 
 import Control.Monad
@@ -23,16 +23,33 @@ import UnliftIO.Process
 
 -- * Types
 
-data KubectlLogsContext = KubectlLogsContext
+data KubectlLogsContext = KubectlLogsContext {
+  kubectlProcessHandle :: ProcessHandle
+  }
 
 -- * Implementation
 
--- | Note that this will stop working if the pod you're talking to goes away (even if you do it against a service)
+-- | Run a @kubectl logs@ process, placing the logs in a file in the current test node directory.
+--
+-- Note that this will stop working if the pod you're talking to goes away (even if you do it against a service).
 -- If this happens, a rerun of the command is needed to resume forwarding
 withKubectlLogs :: (
   MonadLogger m, MonadFail m, MonadUnliftIO m
   , HasBaseContextMonad ctx m, HasFile ctx "kubectl"
-  ) => FilePath -> Text -> Text -> Maybe Text -> Bool -> (KubectlLogsContext -> m a) -> m a
+  )
+  -- | Kubeconfig file
+  => FilePath
+  -- | Namespace
+  -> Text
+  -- | Log target (pod, service, etc.)
+  -> Text
+  -- | Specific container to get logs from
+  -> Maybe Text
+  -- | Whether to interrupt the process to shut it down while cleaning up
+  -> Bool
+  -- | Callback receiving the 'KubectlLogsContext'
+  -> (KubectlLogsContext -> m a)
+  -> m a
 withKubectlLogs kubeConfigFile namespace target maybeContainer interruptWhenDone action = do
   kubectlBinary <- askFile @"kubectl"
 
@@ -58,6 +75,6 @@ withKubectlLogs kubeConfigFile namespace target maybeContainer interruptWhenDone
                 | interruptWhenDone -> void $ gracefullyStopProcess ps 30_000_000
                 | otherwise -> void $ waitForProcess ps
             )
-            (\_ -> do
-                action KubectlLogsContext
+            (\(_, _, _, ps) -> do
+                action $ KubectlLogsContext ps
             )

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs

@@ -2,10 +2,9 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Sandwich.Contexts.Kubernetes.KubectlPortForward (
-  KubectlPortForwardContext (..)
-
-  , withKubectlPortForward
+  withKubectlPortForward
   , withKubectlPortForward'
+  , KubectlPortForwardContext (..)
   ) where
 
 import Control.Monad
@@ -39,20 +38,38 @@ newtype KubectlPortForwardContext = KubectlPortForwardContext {
 
 -- * Implementation
 
+-- | Run a @kubectl port-forward@ process, making the port available in the 'KubectlPortForwardContext'.
+--
+-- Note that this will stop working if the pod you're talking to goes away (even if you do it against a service).
+-- If this happens, a rerun of the command is needed to resume forwarding
 withKubectlPortForward :: (
   HasCallStack, MonadCatch m, MonadLogger m, MonadUnliftIO m
   , HasBaseContextMonad ctx m, HasFile ctx "kubectl"
-  ) => FilePath -> Text -> Text -> PortNumber -> (KubectlPortForwardContext -> m a) -> m a
+  )
+  => FilePath
+  -> Text
+  -> Text
+  -> PortNumber
+  -> (KubectlPortForwardContext -> m a)
+  -> m a
 withKubectlPortForward kubeConfigFile namespace targetName targetPort action = do
   kubectlBinary <- askFile @"kubectl"
   withKubectlPortForward' kubectlBinary kubeConfigFile namespace (const True) Nothing targetName targetPort action
 
--- | 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
+-- | Same as 'withKubectlPortForward', but allows you to pass in the @kubectl@ binary path.
 withKubectlPortForward' :: (
   HasCallStack, MonadCatch m, MonadLogger m, MonadUnliftIO m
   , HasBaseContextMonad ctx m
-  ) => FilePath -> FilePath -> Text -> (PortNumber -> Bool) -> Maybe PortNumber -> Text -> PortNumber -> (KubectlPortForwardContext -> m a) -> m a
+  )
+  => 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
 

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs

@@ -14,6 +14,11 @@ module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster (
   , withMinikubeCluster
   , withMinikubeCluster'
 
+  -- * Image management
+  , Images.clusterContainsImage
+  , Images.getLoadedImages
+  , Images.loadImage
+
   -- * Re-exported cluster types
   , kubernetesCluster
   , KubernetesClusterContext (..)
@@ -37,6 +42,7 @@ import System.FilePath
 import System.IO.Temp
 import Test.Sandwich
 import Test.Sandwich.Contexts.Files
+import qualified Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images as Images
 import Test.Sandwich.Contexts.Kubernetes.Types
 import Test.Sandwich.Contexts.Kubernetes.Util.UUID
 import Test.Sandwich.Contexts.Nix
@@ -66,40 +72,45 @@ defaultMinikubeClusterOptions = MinikubeClusterOptions {
 
 -- * Introduce
 
--- | Introduce a Minikube cluster, deriving the minikube binary from the Nix context.
+type MinikubeClusterContext context =
+  LabelValue "kubernetesCluster" KubernetesClusterContext
+  :> LabelValue "file-minikube" (EnvironmentFile "minikube")
+  :> context
+
+-- | Introduce a Minikube cluster, deriving the @minikube@ binary from the Nix context.
 introduceMinikubeClusterViaNix :: (
   HasBaseContext context, MonadUnliftIO m, HasNixContext context
   )
   -- | Options
   => MinikubeClusterOptions
   -- | Child spec
-  -> SpecFree (LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-minikube" (EnvironmentFile "minikube") :> context) m ()
+  -> SpecFree (MinikubeClusterContext context) m ()
   -- | Parent spec
   -> SpecFree context m ()
 introduceMinikubeClusterViaNix minikubeClusterOptions spec =
   introduceBinaryViaNixPackage @"minikube" "minikube" $
     introduceWith "introduce minikube cluster" kubernetesCluster (void . withMinikubeCluster minikubeClusterOptions) spec
 
--- | Introduce a Minikube cluster, deriving the minikube binary from the PATH.
+-- | Introduce a Minikube cluster, deriving the @minikube@ binary from the PATH.
 introduceMinikubeClusterViaEnvironment :: (
   HasBaseContext context, MonadUnliftIO m
   )
   -- | Options
   => MinikubeClusterOptions
-  -> SpecFree (LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-minikube" (EnvironmentFile "minikube") :> context) m ()
+  -> SpecFree (MinikubeClusterContext context) m ()
   -> SpecFree context m ()
 introduceMinikubeClusterViaEnvironment minikubeClusterOptions spec =
   introduceBinaryViaEnvironment @"minikube" $
     introduceWith "introduce minikube cluster" kubernetesCluster (void . withMinikubeCluster minikubeClusterOptions) spec
 
--- | Introduce a Minikube cluster, passing in the minikube binary path.
+-- | Introduce a Minikube cluster, passing in the @minikube@ binary path.
 introduceMinikubeCluster' :: (
   HasBaseContext context, MonadUnliftIO m
   )
-  -- | Path to minikube binary
+  -- | Path to @minikube@ binary
   => FilePath
   -> MinikubeClusterOptions
-  -> SpecFree (LabelValue "kubernetesCluster" KubernetesClusterContext :> LabelValue "file-minikube" (EnvironmentFile "minikube") :> context) m ()
+  -> SpecFree (MinikubeClusterContext context) m ()
   -> SpecFree context m ()
 introduceMinikubeCluster' minikubeBinary minikubeClusterOptions spec =
   introduceFile @"minikube" minikubeBinary $
@@ -121,7 +132,7 @@ withMinikubeCluster options action = do
   minikubeBinary <- askFile @"minikube"
   withMinikubeCluster' minikubeBinary options action
 
--- | Same as 'withMinikubeCluster', but allows you to pass the path to the Minikube binary.
+-- | Same as 'withMinikubeCluster', but allows you to pass the path to the @minikube@ binary.
 withMinikubeCluster' :: (
   HasBaseContextMonad context m
   , MonadLoggerIO m, MonadUnliftIO m, MonadFail m

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs

@@ -13,26 +13,21 @@ module Test.Sandwich.Contexts.Kubernetes.Namespace (
   ) where
 
 import Control.Monad
-import Control.Monad.IO.Unlift
-import Control.Monad.Logger
 import Data.String.Interpolate
 import Relude hiding (force)
 import System.Exit
 import Test.Sandwich
-import Test.Sandwich.Contexts.Files
-import Test.Sandwich.Contexts.Kubernetes.KindCluster
 import Test.Sandwich.Contexts.Kubernetes.Kubectl
+import Test.Sandwich.Contexts.Kubernetes.Types
 import UnliftIO.Exception
 import UnliftIO.Process
 
 
 -- | Around-style node to create a Kubernetes namespace, and destroy it at the end.
--- If you're installing something via Helm 3, you may not need this as you can just pass "--create-namespace".
+--
+-- If you're installing something via Helm 3, you may not need this as you can just pass @--create-namespace@.
 withKubernetesNamespace :: (
-  MonadUnliftIO m
-  , HasBaseContext context
-  , HasLabel context "kubernetesCluster" KubernetesClusterContext
-  , HasFile context "kubectl"
+  KubernetesClusterBasic m context
   )
   -- | Namespace to create
   => Text
@@ -42,37 +37,27 @@ withKubernetesNamespace namespace = around [i|Create the '#{namespace}' kubernet
 
 -- | Same as 'withKubernetesNamespace', but works in an arbitrary monad with reader context.
 withKubernetesNamespace' :: (
-  MonadUnliftIO m, MonadLoggerIO m
-  , MonadReader context m
-  , HasBaseContext context
-  , HasLabel context "kubernetesCluster" KubernetesClusterContext
-  , HasFile context "kubectl"
+  KubernetesClusterBasic m context
   )
   -- | Namespace to create
   => Text
   -> m a
   -> m a
 withKubernetesNamespace' namespace = bracket_ (createKubernetesNamespace namespace) (destroyKubernetesNamespace False namespace)
 
+-- | Create a Kubernetes namespace.
 createKubernetesNamespace :: (
-  MonadUnliftIO m, MonadLoggerIO m
-  , HasBaseContext context
-  , MonadReader context m
-  , HasKubernetesClusterContext context
-  , HasFile context "kubectl"
+  KubernetesClusterBasic m context
   ) => Text -> m ()
 createKubernetesNamespace namespace = do
   let args = ["create", "namespace", toString namespace]
   (kubectl, env) <- askKubectlArgs
   createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
+-- | Destroy a Kubernetes namespace.
 destroyKubernetesNamespace :: (
-  MonadUnliftIO m, MonadLoggerIO m
-  , HasBaseContext context
-  , MonadReader context m
-  , HasKubernetesClusterContext context
-  , HasFile context "kubectl"
+  KubernetesClusterBasic m context
   ) => Bool -> Text -> m ()
 destroyKubernetesNamespace force namespace = do
   let args = ["delete", "namespace", toString namespace]