content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE TypeOperators #-}
  
  module Test.Sandwich.Contexts.Kubernetes.KindCluster.ServiceForwardIngress (
    withForwardKubernetesService'
    ) where
  
  import Control.Monad
  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.IO as T
  import Network.Socket (PortNumber)
  import Network.URI
  import Relude hiding (withFile)
  import Safe
  import System.Exit
  import System.FilePath
  import qualified System.Random as R
  import Test.Sandwich
  import Test.Sandwich.Contexts.Kubernetes.Types
  import Test.Sandwich.Util.Process
  import Text.Regex.TDFA
  import UnliftIO.Environment
  import UnliftIO.Exception
  import UnliftIO.IO (withFile)
  import UnliftIO.Process
  import UnliftIO.Temporary
  import UnliftIO.Timeout
  
  
  withForwardKubernetesService' :: (
    MonadUnliftIO m, MonadLoggerIO m
    ) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a
  withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) kubectlBinary namespace service action = do
    baseEnv <- maybe getEnvironment return kubernetesClusterTypeKindClusterEnvironment
    let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
  
    randomHost <- generateRandomHostname
  
    withSystemTempDirectory "ingress.yaml" $ \dir -> do
      let configFile = dir </> "ingress.yaml"
      liftIO $ T.writeFile configFile (ingressConfig service randomHost)
  
      createProcessWithLogging ((proc kubectlBinary ["create"
                                                    , "--namespace", toString namespace
                                                    , "-f", configFile]) {
                                   env = Just env
                                   }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
  
    -- TODO: wait for ingress to be ready?
    -- Possibly not necessary since the server context waits for 200 after this
  
    nodes <- ((T.words . toText) <$> (readCreateProcessWithLogging ((shell [i|kind get nodes --name "#{kubernetesClusterName}"|]) { env = Just env }) ""))
    controlPlaneNode <- case headMay [t | t <- nodes, "control-plane" `T.isInfixOf` t] of
      Nothing -> expectationFailure [i|Couldn't find control plane node (had: #{nodes})|]
      Just x -> pure x
  
    hostAndPort <- (T.strip . toText) <$> readCreateProcessWithLogging (
      proc (toString kubernetesClusterTypeKindClusterDriver) [
        "port", toString controlPlaneNode, "80/tcp"
        ]) ""
    let caddyArgs :: [String] = [
          "reverse-proxy"
          , "--from", "http://localhost:0"
          , "--to", "http://" <> toString hostAndPort
          , "--header-up", [i|Host: #{randomHost}|]
          ]
  
    info [i|caddy args: #{T.intercalate " " $ fmap toText caddyArgs}|]
    (stdoutRead, stdoutWrite) <- createPipe
    withFile "/dev/null" WriteMode $ \hNull -> do
      let cp = (proc "caddy" caddyArgs) {
            std_err = UseHandle stdoutWrite
            , std_out = UseHandle hNull
            , create_group = True
            }
      bracket (createProcess cp) (\(_, _, _, p) -> gracefullyStopProcess p 60_000_000) $ \_ -> do
        uriToUseMaybe <- timeout 60_000_000 $ fix $ \loop -> do
          line <- liftIO $ T.hGetLine stdoutRead
          debug [i|caddy: #{line}|]
          maybe loop pure (parsePort line)
  
        uriToUse <- case uriToUseMaybe of
          Nothing -> expectationFailure [i|Timed out waiting for caddy line with actual port|]
          Just x -> pure [i|http://localhost:#{x}|]
        info [i|uriToUse: #{uriToUse}|]
  
        action =<< case parseURI uriToUse of
          Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{uriToUse}|]
          Just x -> pure x
  
  withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"
  
  
  ingressConfig :: Text -> Text -> Text
  ingressConfig service host = [i|
  apiVersion: networking.k8s.io/v1
  kind: Ingress
  metadata:
    name: #{service}-ingress
  spec:
    rules:
    - host: #{host}
      http:
        paths:
        - path: /
          pathType: Prefix
          backend:
            service:
              name: #{service}
              port:
                number: 80
  |]
  
  
  generateRandomHostname :: MonadIO m => m Text
  generateRandomHostname = (toText <$>) $ liftIO $ do
    labelCount <- R.randomRIO (1, 5)
    labels <- replicateM labelCount (randomAlpha =<< R.randomRIO (5, 10))
    let hostname = L.intercalate "." labels
    return hostname
    where
      randomAlpha :: Int -> IO String
      randomAlpha len = do
        gen <- R.newStdGen
        return $ L.take len (R.randomRs ('a', 'z') gen)
  
  
  -- test :: Text
  -- test = [i|"actual_address": "[::]:46763"|]
  
  parsePort :: Text -> Maybe PortNumber
  parsePort t = case t =~~ ([i|"actual_address":[[:space:]]*"\\[::\\]:([[:digit:]]+)"|] :: Text) of
    Just ((_before, _fullMatch, _after, [(readMay . toString) -> Just p]) :: (Text, Text, Text, [Text])) -> Just p
    _ -> Nothing
  