Forwards.hs

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

module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Forwards 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 Network.URI
import Relude hiding (withFile)
import System.IO (hGetLine)
import System.Process (getPid)
import Test.Sandwich
import Test.Sandwich.Contexts.Kubernetes.Types
import Test.Sandwich.Util.Process
import UnliftIO.Async
import UnliftIO.Environment
import UnliftIO.Exception
import UnliftIO.Process


withForwardKubernetesService' :: (
  HasCallStack, MonadLoggerIO m, MonadUnliftIO m
  ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) profile namespace service action = do
  baseEnv <- liftIO getEnvironment
  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)

  let extraFlags = case "--rootless" `L.elem` kubernetesClusterTypeMinikubeFlags of
        True -> ["--rootless"]
        False -> []

  let args = extraFlags <> [
        "--profile", toString profile
        , "--namespace", toString namespace
        , "--logtostderr"
        , "service"
        , toString service
        , "--url"]
  info [i|#{kubernetesClusterTypeMinikubeBinary} #{T.unwords $ fmap toText args}|]

  (stdoutRead, stdoutWrite) <- liftIO createPipe
  (stderrRead, stderrWrite) <- liftIO createPipe

  let forwardStderr = forever $ do
        line <- liftIO $ hGetLine stderrRead
        info [i|minikube service stderr: #{line}|]

  withAsync forwardStderr $ \_ -> do
    let cp = (proc kubernetesClusterTypeMinikubeBinary args) {
          env = Just env
          , std_out = UseHandle stdoutWrite
          , std_err = UseHandle stderrWrite
          , create_group = True
          }

    let stop (_, _, _, p) = liftIO (getPid p) >>= \case
          Nothing -> return ()
          Just _pid -> gracefullyStopProcess p 120_000_000

    bracket (createProcess cp) stop $ \_ -> do
      raw <- liftIO $ hGetLine stdoutRead

      info [i|withForwardKubernetesService': (#{namespace}) #{service} -> #{raw}|]

      action =<< case parseURI (toString (T.strip (toText raw))) of
        Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{raw}|]
        Just x -> pure x

withForwardKubernetesService' _ _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"