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

module Test.Sandwich.Contexts.Kubernetes.KindCluster.Config where

import Data.Aeson as A
import Data.Aeson.TH as A
import qualified Data.List as L
import Data.String.Interpolate
import qualified Data.Vector as V
import Relude


data ExtraPortMapping = ExtraPortMapping {
  ExtraPortMapping -> Int16
containerPort :: Int16
  , ExtraPortMapping -> Int16
hostPort :: Int16

  -- | Set the bind address on the host
  -- 0.0.0.0 is the current default
  , ExtraPortMapping -> Maybe String
listenAddress :: Maybe String

  -- | Set the protocol to one of TCP, UDP, SCTP.
  --  TCP is the default
  , ExtraPortMapping -> Maybe String
protocol :: Maybe String
  }
deriveToJSON A.defaultOptions ''ExtraPortMapping

data ExtraMount = ExtraMount {
  ExtraMount -> String
hostPath :: String
  , ExtraMount -> String
containerPath :: String
  -- | If set, the mount is read-only.
  -- default false
  , ExtraMount -> Maybe Bool
readOnly :: Maybe Bool
  -- | If set, the mount needs SELinux relabeling.
  -- default false
  , ExtraMount -> Maybe Bool
selinuxRelabel :: Maybe Bool

  -- | Set propagation mode (None, HostToContainer or Bidirectional).
  -- See https://kubernetes.io/docs/concepts/storage/volumes/#mount-propagation.
  --
  -- WARNING: You very likely do not need this field.
  --
  -- This field controls propagation of *additional* mounts created
  -- at runtime underneath this mount.
  --
  -- On MacOS with Docker Desktop, if the mount is from macOS and not the
  -- docker desktop VM, you cannot use this field. You can use it for
  -- mounts to the linux VM.
  , ExtraMount -> Maybe String
propagation :: Maybe String
  }
deriveToJSON A.defaultOptions ''ExtraMount

kindConfig :: Int -> Map Text Text -> [ExtraPortMapping] -> [ExtraMount] -> A.Value
kindConfig :: Int -> Map Text Text -> [ExtraPortMapping] -> [ExtraMount] -> Value
kindConfig Int
numNodes Map Text Text
_containerLabels [ExtraPortMapping]
extraPortMappings [ExtraMount]
extraMounts = [Pair] -> Value
A.object [
  (Key
"kind", Text -> Value
A.String Text
"Cluster")
  , (Key
"apiVersion", Text -> Value
A.String Text
"kind.x-k8s.io/v1alpha4")
  , (Key
"nodes", Array -> Value
A.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
nodes))
  ]
  where
    nodes :: [Value]
nodes = Text -> Value
mkNode Text
"control-plane" Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: (Int -> Value -> [Value]
forall a. Int -> a -> [a]
L.replicate (Int
numNodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Text -> Value
mkNode Text
"worker"))

    mkNode :: Text -> A.Value
    mkNode :: Text -> Value
mkNode Text
role = [Pair] -> Value
A.object ([
      (Key
"role", Text -> Value
A.String Text
role)
      ]
      [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> if Text
role Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"control-plane" then [(Key
"kubeadmConfigPatches", Array -> Value
A.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList [Text -> Value
A.String Text
extraPatches]))] else []
      [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> if [ExtraPortMapping] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [ExtraPortMapping]
extraPortMappings then [] else [(Key
"extraPortMappings", Array -> Value
A.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList ((ExtraPortMapping -> Value) -> [ExtraPortMapping] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtraPortMapping -> Value
forall a. ToJSON a => a -> Value
A.toJSON [ExtraPortMapping]
extraPortMappings)))]
      [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> if [ExtraMount] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [ExtraMount]
extraMounts then [] else [(Key
"extraMounts", Array -> Value
A.Array ([Value] -> Array
forall a. [a] -> Vector a
V.fromList ((ExtraMount -> Value) -> [ExtraMount] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtraMount -> Value
forall a. ToJSON a => a -> Value
A.toJSON [ExtraMount]
extraMounts)))]
      )

    extraPatches :: Text
extraPatches = [__i|kind: InitConfiguration
                        nodeRegistration:
                          kubeletExtraArgs:
                            node-labels: "ingress-ready=true"
                            authorization-mode: "AlwaysAllow"
                            streaming-connection-idle-timeout: "0"
                       |]


-- Note: here's how to provide an extra container registry:
-- containerdConfigPatches:
-- - |-
--   [plugins."io.containerd.grpc.v1.cri".registry.mirrors."#{registryHostname}:5000"]
--     endpoint = ["http://#{registryHostname}:5000"]