{-# 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' :: forall (m :: * -> *) a.
(HasCallStack, MonadLoggerIO m, MonadUnliftIO m) =>
KubernetesClusterContext
-> Text -> Text -> Text -> (URI -> m a) -> m a
withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType :: KubernetesClusterContext -> KubernetesClusterType
kubernetesClusterType=(KubernetesClusterMinikube {String
[Text]
Text
kubernetesClusterTypeMinikubeBinary :: String
kubernetesClusterTypeMinikubeProfileName :: Text
kubernetesClusterTypeMinikubeFlags :: [Text]
kubernetesClusterTypeMinikubeFlags :: KubernetesClusterType -> [Text]
kubernetesClusterTypeMinikubeProfileName :: KubernetesClusterType -> Text
kubernetesClusterTypeMinikubeBinary :: KubernetesClusterType -> String
..}), Int
String
(Manager, KubernetesClientConfig)
Text
kubernetesClusterName :: Text
kubernetesClusterKubeConfigPath :: String
kubernetesClusterNumNodes :: Int
kubernetesClusterClientConfig :: (Manager, KubernetesClientConfig)
kubernetesClusterClientConfig :: KubernetesClusterContext -> (Manager, KubernetesClientConfig)
kubernetesClusterNumNodes :: KubernetesClusterContext -> Int
kubernetesClusterKubeConfigPath :: KubernetesClusterContext -> String
kubernetesClusterName :: KubernetesClusterContext -> Text
..}) Text
profile Text
namespace Text
service URI -> m a
action = do
  baseEnv <- IO [(String, String)] -> m [(String, String)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
forall (m :: * -> *). MonadIO m => m [(String, String)]
getEnvironment
  let env = ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\(String, String)
x (String, String)
y -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
y) ((String
"KUBECONFIG", String
kubernetesClusterKubeConfigPath) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
baseEnv)

  let extraFlags = case Text
"--rootless" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text]
kubernetesClusterTypeMinikubeFlags of
        Bool
True -> [String
"--rootless"]
        Bool
False -> []

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

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

  let forwardStderr = m () -> m (ZonkAny 0)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m (ZonkAny 0)) -> m () -> m (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ do
        line <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
stderrRead
        info [i|minikube service stderr: #{line}|]

  withAsync forwardStderr $ \Async (ZonkAny 0)
_ -> do
    let cp :: CreateProcess
cp = (String -> [String] -> CreateProcess
proc String
kubernetesClusterTypeMinikubeBinary [String]
args) {
          env = Just env
          , std_out = UseHandle stdoutWrite
          , std_err = UseHandle stderrWrite
          , create_group = True
          }

    let stop :: (a, b, c, ProcessHandle) -> m ()
stop (a
_, b
_, c
_, ProcessHandle
p) = IO (Maybe Pid) -> m (Maybe Pid)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO (Maybe Pid)
getPid ProcessHandle
p) m (Maybe Pid) -> (Maybe Pid -> 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
>>= \case
          Maybe Pid
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just Pid
_pid -> ProcessHandle -> Int -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyStopProcess ProcessHandle
p Int
120_000_000

    m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> m ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *).
MonadIO m =>
CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> m ()
forall {m :: * -> *} {a} {b} {c}.
(MonadIO m, MonadLogger m) =>
(a, b, c, ProcessHandle) -> m ()
stop (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> m a)
 -> m a)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> m a)
-> m a
forall a b. (a -> b) -> a -> b
$ \(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ -> do
      raw <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
stdoutRead

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

      action =<< case parseURI (toString (T.strip (toText raw))) of
        Maybe URI
Nothing -> String -> m URI
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{raw}|]
        Just URI
x -> URI -> m URI
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
x

withForwardKubernetesService' KubernetesClusterContext
_ Text
_profile Text
_namespace Text
_service URI -> m a
_action = Text -> m a
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Expected Minikube KubernetesClusterContext"