|
| 1 | +{-# LANGUAGE OverloadedStrings #-} |
| 2 | +module Main where |
| 3 | + |
| 4 | +import Control.Concurrent.STM |
| 5 | +import Control.Exception.Safe |
| 6 | +import Kubernetes.Client |
| 7 | +import Kubernetes.OpenAPI |
| 8 | +import Kubernetes.OpenAPI.API.AppsV1 |
| 9 | +import Kubernetes.OpenAPI.API.CoreV1 |
| 10 | +import Network.HTTP.Client |
| 11 | +import Network.HTTP.Types.Status |
| 12 | +import System.Environment |
| 13 | + |
| 14 | +import qualified Data.Map as Map |
| 15 | +import qualified Data.Text as T |
| 16 | +import qualified Data.Text.IO as T |
| 17 | + |
| 18 | +main :: IO () |
| 19 | +main = do |
| 20 | + kubeConfigFile <- getEnv "KUBECONFIG" |
| 21 | + oidcCache <- newTVarIO $ Map.fromList [] |
| 22 | + (manager, cfg) <- mkKubeClientConfig oidcCache |
| 23 | + $ KubeConfigFile kubeConfigFile |
| 24 | + let createNamespaceRequest = |
| 25 | + createNamespace (ContentType MimeJSON) (Accept MimeJSON) testNamespace |
| 26 | + createdNS <- assertMimeSuccess =<< dispatchMime manager cfg createNamespaceRequest |
| 27 | + nsName <- assertJust "Expected K8s to generate name for namespace, but it didn't" |
| 28 | + $ (v1ObjectMetaName =<< v1NamespaceMetadata createdNS) |
| 29 | + T.putStrLn $ "Created Namespace: " <> nsName |
| 30 | + |
| 31 | + let createDeploymentRequest = |
| 32 | + createNamespacedDeployment (ContentType MimeJSON) (Accept MimeJSON) testDeployment (Namespace nsName) |
| 33 | + deployment <- assertMimeSuccess =<< dispatchMime manager cfg createDeploymentRequest |
| 34 | + T.putStrLn $ "Created Deployment: " <> maybe "No name!?" id (v1DeploymentMetadata deployment >>= v1ObjectMetaName) |
| 35 | + |
| 36 | + let listDeploymentsRequest = |
| 37 | + listNamespacedDeployment (Accept MimeJSON) (Namespace nsName) |
| 38 | + listedDeployments <- assertMimeSuccess =<< dispatchMime manager cfg listDeploymentsRequest |
| 39 | + let numberOfDeployments = length $ v1DeploymentListItems listedDeployments |
| 40 | + if numberOfDeployments /= 1 |
| 41 | + then throwM $ AssertionFailure $ "Expected 1 deployment, found: " <> show numberOfDeployments |
| 42 | + else putStrLn "Test successful!" |
| 43 | + |
| 44 | + -- NOTE: We cannot use dispatchMime due to this issue: https://github.com/kubernetes/kubernetes/issues/59501 |
| 45 | + let deleteNamespaceRequest = |
| 46 | + deleteNamespace (ContentType MimeJSON) (Accept MimeJSON) (Name nsName) |
| 47 | + deleteNamespaceResponse <- dispatchLbs manager cfg deleteNamespaceRequest |
| 48 | + if responseStatus deleteNamespaceResponse /= status200 |
| 49 | + then throwM $ AssertionFailure |
| 50 | + $ "Failed to cleanup namespace: " <> T.unpack nsName |
| 51 | + <> "\nStatus Code: " <> show (responseStatus deleteNamespaceResponse) |
| 52 | + <> "\nBody: " <> show (responseBody deleteNamespaceResponse) |
| 53 | + else return () |
| 54 | + putStrLn "Clenaup complete!" |
| 55 | + |
| 56 | +testDeployment :: V1Deployment |
| 57 | +testDeployment = |
| 58 | + let labelSelector = |
| 59 | + mkV1LabelSelector |
| 60 | + { v1LabelSelectorMatchLabels = |
| 61 | + Just $ Map.fromList [("app", "test")] } |
| 62 | + container = |
| 63 | + (mkV1Container "container-name") |
| 64 | + { v1ContainerImage = Just $ "nginx" } |
| 65 | + podTemplate = |
| 66 | + mkV1PodTemplateSpec |
| 67 | + { v1PodTemplateSpecMetadata = |
| 68 | + Just $ mkV1ObjectMeta |
| 69 | + { v1ObjectMetaLabels = Just $ Map.fromList [("app", "test")] } |
| 70 | + , v1PodTemplateSpecSpec = |
| 71 | + Just $ |
| 72 | + mkV1PodSpec [container] |
| 73 | + } |
| 74 | + in mkV1Deployment |
| 75 | + { v1DeploymentMetadata = |
| 76 | + Just $ mkV1ObjectMeta { v1ObjectMetaName = Just "test-deployment" } |
| 77 | + , v1DeploymentSpec = |
| 78 | + Just |
| 79 | + $ (mkV1DeploymentSpec labelSelector podTemplate) |
| 80 | + } |
| 81 | + |
| 82 | +testNamespace :: V1Namespace |
| 83 | +testNamespace = |
| 84 | + let nsMetadata = |
| 85 | + mkV1ObjectMeta |
| 86 | + { v1ObjectMetaGenerateName = Just "haskell-client-test-" } |
| 87 | + in mkV1Namespace |
| 88 | + { v1NamespaceMetadata = Just nsMetadata } |
| 89 | + |
| 90 | +assertMimeSuccess :: MonadThrow m => MimeResult a -> m a |
| 91 | +assertMimeSuccess (MimeResult (Right res) _) = pure res |
| 92 | +assertMimeSuccess (MimeResult (Left err) _) = |
| 93 | + throwM $ AssertionFailure $ "Unexpected MimeError: " ++ show err |
| 94 | + |
| 95 | +assertJust :: MonadThrow m => String -> Maybe a -> m a |
| 96 | +assertJust err Nothing = throwM $ AssertionFailure err |
| 97 | +assertJust _ (Just x) = return x |
| 98 | + |
| 99 | +data AssertionFailure = AssertionFailure String |
| 100 | + deriving Show |
| 101 | + |
| 102 | +instance Exception AssertionFailure |
0 commit comments