{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Test.Sandwich.Contexts.Kubernetes.Run where

import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.String.Interpolate
import Kubernetes.OpenAPI.Client as Kubernetes
import Kubernetes.OpenAPI.Core as Kubernetes
import Kubernetes.OpenAPI.MimeTypes
import Network.HTTP.Client
import Relude
import Test.Sandwich
import Test.Sandwich.Contexts.Kubernetes.Types
import UnliftIO.Exception


type Constraints context m = (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadReader context m)

instance Exception MimeError

-- * Run Exception

k8sRunException :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m, HasKubernetesClusterContext context)
  => KubernetesRequest req contentType res accept -> m res
k8sRunException :: forall req accept res contentType context (m :: * -> *).
(Produces req accept, MimeUnrender accept res,
 MimeType contentType, Constraints context m,
 HasKubernetesClusterContext context) =>
KubernetesRequest req contentType res accept -> m res
k8sRunException KubernetesRequest req contentType res accept
req = do
  (manager, clientConfig) <- KubernetesClusterContext -> (Manager, KubernetesClientConfig)
kubernetesClusterClientConfig (KubernetesClusterContext -> (Manager, KubernetesClientConfig))
-> m KubernetesClusterContext
-> m (Manager, KubernetesClientConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label "kubernetesCluster" KubernetesClusterContext
-> 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
  k8sRunException' manager clientConfig req

k8sRunException' :: (MimeUnrender accept res, MimeType contentType, Produces req accept, Constraints context m)
  => Manager -> KubernetesClientConfig -> KubernetesRequest req contentType res accept -> m res
k8sRunException' :: forall accept res contentType req context (m :: * -> *).
(MimeUnrender accept res, MimeType contentType,
 Produces req accept, Constraints context m) =>
Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m res
k8sRunException' Manager
manager KubernetesClientConfig
clientConfig KubernetesRequest req contentType res accept
req = Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m (Either MimeError res)
forall req accept res contentType context (m :: * -> *).
(Produces req accept, MimeUnrender accept res,
 MimeType contentType, Constraints context m) =>
Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m (Either MimeError res)
k8sRunEither'' Manager
manager KubernetesClientConfig
clientConfig KubernetesRequest req contentType res accept
req m (Either MimeError res)
-> (Either MimeError res -> m res) -> m res
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left MimeError
err -> MimeError -> m res
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO MimeError
err
  Right res
x -> res -> m res
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return res
x

-- * Run Either

k8sRunEither :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m, HasKubernetesClusterContext context)
  => KubernetesRequest req contentType res accept -> m (Either Text res)
k8sRunEither :: forall req accept res contentType context (m :: * -> *).
(Produces req accept, MimeUnrender accept res,
 MimeType contentType, Constraints context m,
 HasKubernetesClusterContext context) =>
KubernetesRequest req contentType res accept -> m (Either Text res)
k8sRunEither KubernetesRequest req contentType res accept
req = do
  (manager, clientConfig) <- KubernetesClusterContext -> (Manager, KubernetesClientConfig)
kubernetesClusterClientConfig (KubernetesClusterContext -> (Manager, KubernetesClientConfig))
-> m KubernetesClusterContext
-> m (Manager, KubernetesClientConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label "kubernetesCluster" KubernetesClusterContext
-> 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
  k8sRunEither' manager clientConfig req

k8sRunEither' :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m)
  => Manager -> KubernetesClientConfig -> KubernetesRequest req contentType res accept -> m (Either Text res)
k8sRunEither' :: forall req accept res contentType context (m :: * -> *).
(Produces req accept, MimeUnrender accept res,
 MimeType contentType, Constraints context m) =>
Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m (Either Text res)
k8sRunEither' Manager
manager KubernetesClientConfig
clientConfig KubernetesRequest req contentType res accept
req = (MimeError -> Text) -> Either MimeError res -> Either Text res
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MimeError -> Text
forall b a. (Show a, IsString b) => a -> b
show (Either MimeError res -> Either Text res)
-> m (Either MimeError res) -> m (Either Text res)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m (Either MimeError res)
forall req accept res contentType context (m :: * -> *).
(Produces req accept, MimeUnrender accept res,
 MimeType contentType, Constraints context m) =>
Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m (Either MimeError res)
k8sRunEither'' Manager
manager KubernetesClientConfig
clientConfig KubernetesRequest req contentType res accept
req

k8sRunEither'' :: (Produces req accept, MimeUnrender accept res, MimeType contentType, Constraints context m)
  => Manager -> KubernetesClientConfig -> KubernetesRequest req contentType res accept -> m (Either MimeError res)
k8sRunEither'' :: forall req accept res contentType context (m :: * -> *).
(Produces req accept, MimeUnrender accept res,
 MimeType contentType, Constraints context m) =>
Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> m (Either MimeError res)
k8sRunEither'' Manager
k8sManager KubernetesClientConfig
k8sClientConfig KubernetesRequest req contentType res accept
req = do
  MimeResult parsedResult _httpResponse <- IO (MimeResult res) -> m (MimeResult res)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> IO (MimeResult res)
forall req contentType res accept.
(Produces req accept, MimeUnrender accept res,
 MimeType contentType) =>
Manager
-> KubernetesClientConfig
-> KubernetesRequest req contentType res accept
-> IO (MimeResult res)
dispatchMime Manager
k8sManager KubernetesClientConfig
k8sClientConfig KubernetesRequest req contentType res accept
req)

  let successMessage = case Either MimeError res
parsedResult of
        Left MimeError
err -> Text
"FAIL: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MimeError -> Text
forall b a. (Show a, IsString b) => a -> b
show MimeError
err
        Either MimeError res
_ -> Text
"SUCCESS" :: Text

  debug [i|Kubernetes request: #{rMethod req} to #{BL.intercalate "/" $ rUrlPath req} = #{successMessage}|]

  return parsedResult