{-# 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 (Int -> MinioOperatorContext -> ShowS
[MinioOperatorContext] -> ShowS
MinioOperatorContext -> String
(Int -> MinioOperatorContext -> ShowS)
-> (MinioOperatorContext -> String)
-> ([MinioOperatorContext] -> ShowS)
-> Show MinioOperatorContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MinioOperatorContext -> ShowS
showsPrec :: Int -> MinioOperatorContext -> ShowS
$cshow :: MinioOperatorContext -> String
show :: MinioOperatorContext -> String
$cshowList :: [MinioOperatorContext] -> ShowS
showList :: [MinioOperatorContext] -> ShowS
Show)

minioOperator :: Label "minioOperator" MinioOperatorContext
minioOperator :: Label "minioOperator" MinioOperatorContext
minioOperator = Label "minioOperator" MinioOperatorContext
forall {k} (l :: Symbol) (a :: k). Label l a
Label
type HasMinioOperatorContext context = HasLabel context "minioOperator" MinioOperatorContext

data MinioOperatorOptions = MinioOperatorOptions {
  MinioOperatorOptions -> Bool
minioOperatorPreloadImages :: Bool
  }
defaultMinioOperatorOptions :: MinioOperatorOptions
defaultMinioOperatorOptions :: MinioOperatorOptions
defaultMinioOperatorOptions = MinioOperatorOptions {
  minioOperatorPreloadImages :: Bool
minioOperatorPreloadImages = Bool
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 :: forall context (m :: * -> *).
KubectlBasicWithoutReader context m =>
MinioOperatorOptions
-> SpecFree
     (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
-> SpecFree context m ()
introduceMinioOperator MinioOperatorOptions
options = String
-> Label "minioOperator" MinioOperatorContext
-> ((HasCallStack =>
     MinioOperatorContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
-> SpecFree context m ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"introduce MinIO operator" Label "minioOperator" MinioOperatorContext
minioOperator (((HasCallStack =>
   MinioOperatorContext -> ExampleT context m [Result])
  -> ExampleT context m ())
 -> SpecFree
      (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
 -> SpecFree context m ())
-> ((HasCallStack =>
     MinioOperatorContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HasCallStack => MinioOperatorContext -> ExampleT context m [Result]
action -> do
  kcc <- Label "kubernetesCluster" KubernetesClusterContext
-> ExampleT context m KubernetesClusterContext
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext Label "kubernetesCluster" KubernetesClusterContext
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' :: forall (m :: * -> *) context.
(HasCallStack, MonadFail m, MonadUnliftIO m,
 HasKubernetesClusterContext context, HasBaseContext context) =>
String
-> MinioOperatorOptions
-> SpecFree
     (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
-> SpecFree context m ()
introduceMinioOperator' String
kubectlBinary MinioOperatorOptions
options = String
-> Label "minioOperator" MinioOperatorContext
-> ((HasCallStack =>
     MinioOperatorContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
-> SpecFree context m ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"introduce MinIO operator" Label "minioOperator" MinioOperatorContext
minioOperator (((HasCallStack =>
   MinioOperatorContext -> ExampleT context m [Result])
  -> ExampleT context m ())
 -> SpecFree
      (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
 -> SpecFree context m ())
-> ((HasCallStack =>
     MinioOperatorContext -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "minioOperator" MinioOperatorContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HasCallStack => MinioOperatorContext -> ExampleT context m [Result]
action -> do
  kcc <- Label "kubernetesCluster" KubernetesClusterContext
-> ExampleT context m KubernetesClusterContext
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext Label "kubernetesCluster" KubernetesClusterContext
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 :: forall (m :: * -> *) context a.
(HasCallStack, MonadFail m, KubectlBasic context m) =>
MinioOperatorOptions
-> KubernetesClusterContext -> (MinioOperatorContext -> m a) -> m a
withMinioOperator MinioOperatorOptions
options KubernetesClusterContext
kcc MinioOperatorContext -> m a
action = do
  kubectlBinary <- forall (a :: Symbol) context (m :: * -> *).
(MonadReader context m, HasFile context a) =>
m String
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' :: forall (m :: * -> *) context a.
(HasCallStack, MonadFail m, KubernetesBasic context m) =>
String
-> MinioOperatorOptions
-> KubernetesClusterContext
-> (MinioOperatorContext -> m a)
-> m a
withMinioOperator' String
kubectlBinary (MinioOperatorOptions {Bool
minioOperatorPreloadImages :: MinioOperatorOptions -> Bool
minioOperatorPreloadImages :: Bool
..}) KubernetesClusterContext
kcc MinioOperatorContext -> m a
action = do
  env <- KubernetesClusterContext -> m [(String, String)]
forall (m :: * -> *).
MonadLoggerIO m =>
KubernetesClusterContext -> m [(String, String)]
getKubectlEnvironment KubernetesClusterContext
kcc

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

  when minioOperatorPreloadImages $ do
    let images = Text -> [Text]
findAllImages (String -> Text
forall a. ToText a => a -> Text
toText String
allYaml)

    forM_ images $ \Text
image ->
      KubernetesClusterContext -> ImageLoadSpec -> m ()
forall (m :: * -> *) context.
(HasCallStack, MonadFail m, KubernetesBasic context m) =>
KubernetesClusterContext -> ImageLoadSpec -> m ()
loadImageIfNecessary' KubernetesClusterContext
kcc (Text -> ImagePullPolicy -> ImageLoadSpec
ImageLoadSpecDocker Text
image ImagePullPolicy
IfNotPresent)

  let create = CreateProcess -> String -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) =>
CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin ((String -> [String] -> CreateProcess
proc String
kubectlBinary [String
"apply", String
"-f", String
"-"]) { env = Just env }) String
allYaml
                 m ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ExitCode
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ExitCode -> ExitCode -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` ExitCode
ExitSuccess)

  let namespaceToDestroy = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"minio-operator" (Text -> Maybe Text
findNamespace (String -> Text
forall a. ToText a => a -> Text
toText String
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?
        CreateProcess -> String -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) =>
CreateProcess -> String -> m ProcessHandle
createProcessWithLoggingAndStdin ((String -> [String] -> CreateProcess
proc String
kubectlBinary [String
"delete", String
"-f", String
"-"
                                                              , String
"--ignore-not-found", String
"--wait=false", String
"--all=true"
                                                              ]) {
                                             env = Just env, delegate_ctlc = True }) String
allYaml
          m ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ExitCode
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ExitCode -> ExitCode -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` ExitCode
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 :: Text -> Maybe Text
findNamespace = [Text] -> Maybe Text
forall a. [a] -> Maybe a
headMay ([Text] -> Maybe Text) -> (Text -> [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Text
findNamespace' ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"---\n"
  where
    findNamespace' :: Text -> Maybe Text
    findNamespace' :: Text -> Maybe Text
findNamespace' (Text -> Either ParseException V1Namespace
forall a. FromJSON a => Text -> Either ParseException a
decode -> Right (V1Namespace {v1NamespaceKind :: V1Namespace -> Maybe Text
v1NamespaceKind=(Just Text
"Namespace"), v1NamespaceMetadata :: V1Namespace -> Maybe V1ObjectMeta
v1NamespaceMetadata=(Just V1ObjectMeta
meta)})) = V1ObjectMeta -> Maybe Text
v1ObjectMetaName V1ObjectMeta
meta
    findNamespace' Text
_ = Maybe Text
forall a. Maybe a
Nothing

    decode :: FromJSON a => Text -> Either Yaml.ParseException a
    decode :: forall a. FromJSON a => Text -> Either ParseException a
decode = ByteString -> Either ParseException a
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' (ByteString -> Either ParseException a)
-> (Text -> ByteString) -> Text -> Either ParseException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8