MinioOperator.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

{-|

Install the [MinIO Kubernetes operator](https://min.io/docs/minio/kubernetes/upstream/operations/installation.html) onto a Kubernetes cluster.

This is necessary if you want to use the "Test.Sandwich.Contexts.Kubernetes.MinioS3Server" module to create actual S3 servers.

-}

module Test.Sandwich.Contexts.Kubernetes.MinioOperator (
  introduceMinioOperator
  , introduceMinioOperator'

  -- * Bracket-style variants
  , withMinioOperator
  , withMinioOperator'

  -- * Types
  , minioOperator
  , MinioOperatorContext(..)
  , MinioOperatorOptions(..)
  , defaultMinioOperatorOptions
  , HasMinioOperatorContext
  ) where

import Control.Monad
import Control.Monad.IO.Unlift
import Data.Aeson (FromJSON)
import Data.String.Interpolate
import Data.Text as T
import qualified Data.Yaml as Yaml
import Kubernetes.OpenAPI.Model as Kubernetes
import Relude
import Safe
import System.Exit
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Kubernetes.FindImages
import Test.Sandwich.Contexts.Kubernetes.Images
import Test.Sandwich.Contexts.Kubernetes.Kubectl
import Test.Sandwich.Contexts.Kubernetes.Types
import UnliftIO.Exception
import UnliftIO.Process


data MinioOperatorContext = MinioOperatorContext
  deriving (Show)

minioOperator :: Label "minioOperator" MinioOperatorContext
minioOperator = Label
type HasMinioOperatorContext context = HasLabel context "minioOperator" MinioOperatorContext

data MinioOperatorOptions = MinioOperatorOptions {
  minioOperatorPreloadImages :: Bool
  }
defaultMinioOperatorOptions :: MinioOperatorOptions
defaultMinioOperatorOptions = MinioOperatorOptions {
  minioOperatorPreloadImages = True
  }

-- | Install the [MinIO Kubernetes operator](https://min.io/docs/minio/kubernetes/upstream/operations/installation.html) onto a Kubernetes cluster.
introduceMinioOperator :: (
  KubectlBasicWithoutReader context m
  )
  -- | Options
  => MinioOperatorOptions
  -> SpecFree (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
  -> SpecFree context m ()
introduceMinioOperator options = introduceWith "introduce MinIO operator" minioOperator $ \action -> do
  kcc <- getContext kubernetesCluster
  void $ withMinioOperator options kcc action

-- | Same as 'introduceMinioOperator', but allows you to pass in the @kubectl@ binary path.
introduceMinioOperator' :: (
  HasCallStack, MonadFail m, MonadUnliftIO m, HasKubernetesClusterContext context, HasBaseContext context
  )
  -- | Path to @kubectl@ binary
  => FilePath
  -- | Options
  -> MinioOperatorOptions
  -> SpecFree (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
  -> SpecFree context m ()
introduceMinioOperator' kubectlBinary options = introduceWith "introduce MinIO operator" minioOperator $ \action -> do
  kcc <- getContext kubernetesCluster
  void $ withMinioOperator' kubectlBinary options kcc action

-- | Bracket-style variant of 'introduceMinioOperator'.
withMinioOperator :: (
  HasCallStack, MonadFail m, KubectlBasic context m
  )
  -- | Options
  => MinioOperatorOptions
  -> KubernetesClusterContext
  -> (MinioOperatorContext -> m a)
  -> m a
withMinioOperator options kcc action = do
  kubectlBinary <- askFile @"kubectl"
  withMinioOperator' kubectlBinary options kcc action

-- | Same as 'withMinioOperator', but allows you to pass in the @kubectl@ binary path.
withMinioOperator' :: (
  HasCallStack, MonadFail m, KubernetesBasic context m
  )
  -- | Path to @kubectl@ binary
  => FilePath
  -- | Options
  -> MinioOperatorOptions
  -> KubernetesClusterContext
  -> (MinioOperatorContext -> m a)
  -> m a
withMinioOperator' kubectlBinary (MinioOperatorOptions {..}) kcc action = do
  env <- getKubectlEnvironment kcc

  allYaml <- readCreateProcessWithLogging ((proc kubectlBinary ["kustomize", "github.com/minio/operator?ref=v6.0.1"]) { env = Just env }) ""

  when minioOperatorPreloadImages $ do
    let images = findAllImages (toText allYaml)

    forM_ images $ \image ->
      loadImageIfNecessary' kcc (ImageLoadSpecDocker image IfNotPresent)

  let create = createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) allYaml
                 >>= waitForProcess >>= (`shouldBe` ExitSuccess)

  let namespaceToDestroy = fromMaybe "minio-operator" (findNamespace (toText allYaml))
  info [i|Detected MinIO operator namespace: #{namespaceToDestroy}|]

  let destroy = do
        -- I think this is a robust way to delete everything?
        -- Just doing "delete -f -" produces errors, seemingly because the minio-operator Namespace
        -- gets deleted first and then subsequent deletes encounter missing objects.
        -- If this doesn't work, we can fall back to just deleting the namespace below.
        -- But I think this will be better because it should pick up CRDs?
        createProcessWithLoggingAndStdin ((proc kubectlBinary ["delete", "-f", "-"
                                                              , "--ignore-not-found", "--wait=false", "--all=true"
                                                              ]) {
                                             env = Just env, delegate_ctlc = True }) allYaml
          >>= waitForProcess >>= (`shouldBe` ExitSuccess)

        -- createProcessWithLogging ((proc kubectlBinary ["delete", "namespace", toString namespaceToDestroy, "-f"]) {
        --                              env = Just env, delegate_ctlc = True
        --                              })
        --   >>= waitForProcess >>= (`shouldBe` ExitSuccess)

  bracket_ create destroy (action MinioOperatorContext)

-- | Find the first "Namespace" resource in some multi-document YAML and extract its name
findNamespace :: Text -> Maybe Text
findNamespace = headMay . mapMaybe findNamespace' . T.splitOn "---\n"
  where
    findNamespace' :: Text -> Maybe Text
    findNamespace' (decode -> Right (V1Namespace {v1NamespaceKind=(Just "Namespace"), v1NamespaceMetadata=(Just meta)})) = v1ObjectMetaName meta
    findNamespace' _ = Nothing

    decode :: FromJSON a => Text -> Either Yaml.ParseException a
    decode = Yaml.decodeEither' . encodeUtf8