diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright 2022 Rick Owens + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# om-kubernetes + +This package is deprecated in favor of +[haskell-kubernetes](https://hackage.haskell.org/package/haskell-kubernetes) +or [kubernetes-client](https://hackage.haskell.org/package/kubernetes-client) + + +It contains some basic functionality, implemented on an as needed basis, +for communicating with the Kubernetes api from within the cluster. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/om-kubernetes.cabal b/om-kubernetes.cabal new file mode 100644 --- /dev/null +++ b/om-kubernetes.cabal @@ -0,0 +1,53 @@ +cabal-version: 3.0 +name: om-kubernetes +version: 2.3.1.6 +synopsis: om-kubernetes +description: Haskell Kubernetes utilities. +homepage: https://github.com/owensmurray/om-kubernetes +license: MIT +license-file: LICENSE +author: Rick Owens +maintainer: rick@owensmurray.com +copyright: 2022 Owens Murray +-- category: +build-type: Simple +extra-source-files: + LICENSE + README.md + +common warnings + ghc-options: + -Wall + -Wmissing-deriving-strategies + -Wmissing-export-lists + -Wmissing-import-lists + -Wredundant-constraints + +common dependencies + build-depends: + , aeson >= 2.0.3.0 && < 2.1 + , base >= 4.15.0.0 && < 4.16 + , bytestring >= 0.10.12.1 && < 0.11 + , connection >= 0.3.1 && < 0.4 + , data-default-class >= 0.1.2.0 && < 0.2 + , http-client >= 0.7.13.1 && < 0.8 + , http-client-tls >= 0.3.6.1 && < 0.4 + , http-types >= 0.12.3 && < 0.13 + , om-http >= 0.3.0.0 && < 0.4 + , safe-exceptions >= 0.1.7.3 && < 0.2 + , servant >= 0.19 && < 0.20 + , servant-client >= 0.19 && < 0.20 + , servant-client-core >= 0.19 && < 0.20 + , text >= 1.2.5.0 && < 1.3 + , tls >= 1.5.8 && < 1.6 + , x509-store >= 1.6.9 && < 1.7 + +library + import: warnings, dependencies + exposed-modules: + OM.Kubernetes + -- other-modules: + -- other-extensions: + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/src/OM/Kubernetes.hs b/src/OM/Kubernetes.hs new file mode 100644 --- /dev/null +++ b/src/OM/Kubernetes.hs @@ -0,0 +1,655 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +{- | + Description: Access the Kubernetes API from within the cluster. + + This module provides functions that access and operate on the + Kubernetes API. It is designed to be used from pods running within + the K8s cluster itself and it won't work otherwise. +-} +module OM.Kubernetes ( + -- * Creating a handle + newK8s, + K8s, + + -- * Operations + listPods, + postPod, + deletePod, + getPodSpec, + patchService, + getServiceSpec, + postService, + postRoleBinding, + postRole, + postServiceAccount, + postNamespace, + getPodTemplate, + queryPods, + + -- * Types + JsonPatch(..), + PodName(..), + PodSpec(..), + ServiceName(..), + ServiceSpec(..), + RoleBindingSpec(..), + RoleSpec(..), + ServiceAccountSpec(..), + NamespaceSpec(..), + Namespace(..), + PodTemplateName(..), + PodTemplateSpec(..), + Pod(..), +) where + + +import Control.Exception.Safe (throw) +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson ((.:), FromJSON, FromJSONKey, ToJSON, ToJSONKey, Value, + encode, parseJSON, withObject) +import Data.Default.Class (def) +import Data.String (IsString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.X509.CertificateStore (CertificateStore, readCertificateStore) +import Network.Connection (TLSSettings(TLSSettings)) +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (mkManagerSettings) +import Network.HTTP.Types (urlEncode) +import Network.TLS (clientShared, clientSupported, + clientUseServerNameIndication, defaultParamsClient, sharedCAStore, + supportedCiphers) +import Network.TLS.Extra.Cipher (ciphersuite_default) +import OM.HTTP (BearerToken(BearerToken)) +import Servant.API (Accept(contentType), MimeRender(mimeRender), + NoContent(NoContent), ToHttpApiData(toQueryParam), (:>), Capture, + DeleteNoContent, Description, FromHttpApiData, Get, Header', JSON, + Optional, PatchNoContent, PostNoContent, QueryParam', ReqBody, + Required, Strict) +import Servant.API.Generic (GenericMode((:-)), Generic) +import Servant.Client (BaseUrl(BaseUrl), Scheme(Https), ClientEnv, + ClientM, mkClientEnv, runClientM) +import Servant.Client.Generic (genericClient) +import qualified Data.ByteString as BS +import qualified Data.Text.IO as TIO + + +{- | A subset of the kubernetes api spec. -} +data KubernetesApi mode = KubernetesApi + { kPostNamespaceR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> ReqBody '[JSON] NamespaceSpec + :> PostNoContent + , kListPodsR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "pods" + :> Description "List pods" + :> Get '[JSON] PodNameList + , kQueryPodsR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "pods" + :> QueryParam' '[Optional, Required] "labelSelectors" LabelSelectors + :> Description "List pods" + :> Get '[JSON] PodList + , kPostPodR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "pods" + :> Description "Post a pod definition" + :> ReqBody '[JSON] PodSpec + :> PostNoContent + , kDeletePodR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "pods" + :> Description "Delete a pod" + :> Capture "pod-name" PodName + :> DeleteNoContent + , kGetPodSpecR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "pods" + :> Description "Get a pod spec" + :> Capture "pod-name" PodName + :> Get '[JSON] PodSpec + , kGetServiceSpecR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "services" + :> Description "Get the cluster service." + :> Capture "service-name" ServiceName + :> Get '[JSON] ServiceSpec + , kPostServiceR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "services" + :> Description "Post a new serivce." + :> ReqBody '[JSON] ServiceSpec + :> PostNoContent + , kPatchServiceR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "services" + :> Description "Update the cluster spec annotation." + :> Capture "service-name" ServiceName + :> ReqBody '[JsonPatch] JsonPatch + :> PatchNoContent + , kPostRoleR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> Description "Roll API" + :> "roles" + :> ReqBody '[JSON] RoleSpec + :> PostNoContent + , kPostServiceAccountR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> Description "Service Account API" + :> "serviceaccounts" + :> ReqBody '[JSON] ServiceAccountSpec + :> PostNoContent + , kGetPodTemplateR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> "api" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> Description "Pod Templates API" + :> "podtemplates" + :> Capture "template-name" PodTemplateName + :> Get '[JSON] PodTemplateSpec + , kPostRoleBindingR :: mode + :- Header' [Required, Strict] "Authorization" BearerToken + :> Description "Role Binding API" + :> "apis" + :> "rbac.authorization.k8s.io" + :> "v1" + :> "namespaces" + :> Capture "namespace" Namespace + :> "rolebindings" + :> ReqBody '[JSON] RoleBindingSpec + :> PostNoContent + } + deriving stock (Generic) + + +{- | A handle on the kubernetes service. -} +newtype K8s = K8s { + kManager :: Manager + {- ^ + An http client manager configured to work against the + kubernetes api. + -} + } + + +{- | Create a new 'K8s'. -} +newK8s + :: ( MonadIO m + ) + => m K8s +newK8s = liftIO $ + readCertificateStore crtLocation >>= \case + Nothing -> fail "Can't load K8S CA certificate." + Just store -> do + manager <- + newManager + ( + mkManagerSettings + (k8sTLSSettings store) + Nothing + ) + pure K8s { + kManager = manager + } + where + k8sTLSSettings :: CertificateStore -> TLSSettings + k8sTLSSettings store = + TLSSettings $ + (defaultParamsClient mempty mempty) { + clientShared = def { + sharedCAStore = store + }, + clientSupported = def { + supportedCiphers = ciphersuite_default + }, + clientUseServerNameIndication = True + } + crtLocation :: FilePath + crtLocation = "/var/run/secrets/kubernetes.io/serviceaccount/ca.crt" + + +{- | Specify how to patch the pod template spec. -} +newtype JsonPatch = JsonPatch { + unJsonPatch :: Value + } + deriving newtype (ToJSON) +instance Accept JsonPatch where + contentType _proxy = "application/json-patch+json" +instance MimeRender JsonPatch JsonPatch where + mimeRender _ = encode + + +{- | A list of pods. -} +newtype PodNameList = PodNameList { + unPodNameList :: [PodName] + } +instance FromJSON PodNameList where + parseJSON = withObject "Pod List (Names)" $ \o -> do + list <- o .: "items" + PodNameList <$> mapM ((.: "metadata") >=> (.: "name")) list + + +{- ==================================== List all pods ======================= -} +{- | Get the list of pods. -} +kListPods :: BearerToken -> Namespace -> ClientM PodNameList + +{- | List the pods, returning a list of names. -} +listPods :: (MonadIO m) => K8s -> Namespace -> m [PodName] +listPods k namespace = do + token <- getServiceAccountToken + let req = kListPods token namespace + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right list -> pure (unPodNameList list) + + +{- | Query the pods, returning the full JSON for each. -} +queryPods :: (MonadIO m) => K8s -> Namespace -> [(Text, Text)] -> m [Pod] +queryPods k namespace selectors = do + token <- getServiceAccountToken + let req = kQueryPodsR genericClient token namespace (LabelSelectors selectors) + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right (PodList list) -> pure list + + +newtype LabelSelectors = LabelSelectors + { _unLabelSelectors :: [(Text, Text)] + } +instance ToHttpApiData LabelSelectors where + toQueryParam (LabelSelectors selectors) = + decodeUtf8 $ + BS.intercalate + "," + [ urlEncode False (encodeUtf8 (name <> "=" <> value)) + | (name, value) <- selectors + ] + + +newtype PodList = PodList + { _unPodList :: [Pod] + } +instance FromJSON PodList where + parseJSON = + withObject "Pod List" $ \o -> + PodList . fmap Pod <$> + (o .: "items") + + +newtype Pod = Pod + { unPod :: Value + } + deriving newtype (FromJSON, ToJSON) + deriving stock (Show) + + +{- ==================================== Post a new pod ====================== -} +{- | Create a new pod. -} +kPostPod :: BearerToken -> Namespace -> PodSpec -> ClientM NoContent + +{- | Create a new pod. -} +postPod :: (MonadIO m) => K8s -> Namespace -> PodSpec -> m () +postPod k namespace spec = do + token <- getServiceAccountToken + let req = kPostPod token namespace spec + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Delete a pod ======================== -} +{- | Delete a pod. -} +kDeletePod :: BearerToken -> Namespace -> PodName -> ClientM NoContent + +{- | Delete a pod. -} +deletePod :: (MonadIO m) => K8s -> Namespace -> PodName -> m () +deletePod k namespace podName = do + token <- getServiceAccountToken + let req = kDeletePod token namespace podName + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Delete a pod ======================== -} +{- | Get the spec of a specific pod. -} +kGetPodSpec :: BearerToken -> Namespace -> PodName -> ClientM PodSpec + +{- | Get the spec of a specific pod. -} +getPodSpec :: (MonadIO m) => K8s -> Namespace -> PodName -> m PodSpec +getPodSpec k namespace podName = do + token <- getServiceAccountToken + let req = kGetPodSpec token namespace podName + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right spec -> pure spec + + +{- ==================================== Patch a service ===================== -} +{- | Patch a service. -} +kPatchService + :: BearerToken + -> Namespace + -> ServiceName + -> JsonPatch + -> ClientM NoContent + +{- | Patch a service. -} +patchService :: (MonadIO m) => K8s -> Namespace -> ServiceName -> JsonPatch -> m () +patchService k namespace service patch = do + token <- getServiceAccountToken + let req = kPatchService token namespace service patch + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Get a service Spec ================== -} +{- | Get the service spec. -} +kGetServiceSpec + :: BearerToken + -> Namespace + -> ServiceName + -> ClientM ServiceSpec + +{- | Get the service spec. -} +getServiceSpec + :: (MonadIO m) + => K8s + -> Namespace + -> ServiceName + -> m ServiceSpec +getServiceSpec k namespace service = do + token <- getServiceAccountToken + let req = kGetServiceSpec token namespace service + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right spec -> pure spec + + +{- ==================================== Get a Pod Template Spec ============= -} +{- | Get the pod template. -} +kGetPodTemplate + :: BearerToken + -> Namespace + -> PodTemplateName + -> ClientM PodTemplateSpec + +{- | Get the pod template. -} +getPodTemplate + :: (MonadIO m) + => K8s + -> Namespace + -> PodTemplateName + -> m PodTemplateSpec +getPodTemplate k namespace templateName = do + token <- getServiceAccountToken + let req = kGetPodTemplate token namespace templateName + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right spec -> pure spec + + +{- ==================================== Post a service ====================== -} +{- | Post a new service. -} +kPostService + :: BearerToken + -> Namespace + -> ServiceSpec + -> ClientM NoContent + +{- | Post a new service. -} +postService :: (MonadIO m) => K8s -> Namespace -> ServiceSpec -> m () +postService k namespace service = do + token <- getServiceAccountToken + let req = kPostService token namespace service + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Post Role Binding =================== -} +{- | Post a role binding. -} +kPostRoleBinding + :: BearerToken + -> Namespace + -> RoleBindingSpec + -> ClientM NoContent + +{- | Post a role binding. -} +postRoleBinding :: (MonadIO m) => K8s -> Namespace -> RoleBindingSpec -> m () +postRoleBinding k namespace roleBinding = do + token <- getServiceAccountToken + let req = kPostRoleBinding token namespace roleBinding + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Post Role =========================== -} +{- | Post a Role. -} +kPostRole :: BearerToken -> Namespace -> RoleSpec -> ClientM NoContent + +{- | Post a Role. -} +postRole :: (MonadIO m) => K8s -> Namespace -> RoleSpec -> m () +postRole k namespace role = do + token <- getServiceAccountToken + let req = kPostRole token namespace role + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Post Service Account ================ -} +{- | Post a service account. -} +kPostServiceAccount + :: BearerToken + -> Namespace + -> ServiceAccountSpec + -> ClientM NoContent + +{- | Post a service account. -} +postServiceAccount :: (MonadIO m) => K8s -> Namespace -> ServiceAccountSpec -> m () +postServiceAccount k namespace serviceAccount = do + token <- getServiceAccountToken + let req = kPostServiceAccount token namespace serviceAccount + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Post a Namspace ===================== -} +{- | Post a Namespace. -} +kPostNamespace :: BearerToken -> NamespaceSpec -> ClientM NoContent + +{- | Post a Namespace. -} +postNamespace :: (MonadIO m) => K8s -> NamespaceSpec -> m () +postNamespace k namespace = do + token <- getServiceAccountToken + let req = kPostNamespace token namespace + liftIO $ runClientM req (mkEnv k) >>= \case + Left err -> liftIO (throw err) + Right NoContent -> pure () + + +{- ==================================== Other stuff ========================= -} + +KubernetesApi + { kPostNamespaceR = kPostNamespace + , kListPodsR = kListPods + , kPostPodR = kPostPod + , kDeletePodR = kDeletePod + , kGetPodSpecR = kGetPodSpec + , kGetServiceSpecR = kGetServiceSpec + , kPostServiceR = kPostService + , kPatchServiceR = kPatchService + , kPostRoleR = kPostRole + , kPostServiceAccountR = kPostServiceAccount + , kGetPodTemplateR = kGetPodTemplate + , kPostRoleBindingR = kPostRoleBinding + } + = + genericClient + + +{- | The name of a service. -} +newtype ServiceName = ServiceName { + unServiceName :: Text + } + deriving newtype (ToHttpApiData) + + +{- | The specification of a service. -} +newtype ServiceSpec = ServiceSpec { + unServiceSpec :: Value + } + deriving newtype (FromJSON, ToJSON) + + +{- | The name of a pod template. -} +newtype PodTemplateName = PodTemplateName + { unPodTemplateName :: Text + } + deriving newtype ( + Eq, Ord, Show, IsString, ToHttpApiData, FromHttpApiData, ToJSON, + FromJSON, ToJSONKey, FromJSONKey + ) + + +{- | The specification of a pod template. -} +newtype PodTemplateSpec = PodTempalteSpec + { unPodTemplateSpec :: Value + } + deriving newtype (FromJSON, ToJSON) + + +{- | A pod specification. -} +newtype PodSpec = PodSpec { + unPodSpec :: Value + } + deriving newtype (FromJSON, ToJSON) + + +{- | A Kubernetes namespace. -} +newtype Namespace = Namespace + { unNamespace :: Text + } + deriving newtype ( + Eq, Ord, Show, IsString, ToHttpApiData, FromHttpApiData, ToJSON, + FromJSON, ToJSONKey, FromJSONKey + ) + + +{- | The name of a pod. -} +newtype PodName = PodName { + unPodName :: Text + } + deriving newtype ( + Eq, Ord, Show, IsString, ToHttpApiData, FromHttpApiData, ToJSON, + FromJSON, ToJSONKey, FromJSONKey + ) + + +{- | The representation of Role Binding. -} +newtype RoleBindingSpec = RoleBindingSpec { + unRoleBindingSpec :: Value + } + deriving newtype (ToJSON, FromJSON) + + +{- | Get the k8s service account token. -} +getServiceAccountToken :: (MonadIO m) => m BearerToken +getServiceAccountToken = + fmap BearerToken + . liftIO + . TIO.readFile + $ "/var/run/secrets/kubernetes.io/serviceaccount/token" + + +mkEnv :: K8s -> ClientEnv +mkEnv = + mkEnv_ . kManager + where + mkEnv_ :: Manager -> ClientEnv + mkEnv_ manager = + mkClientEnv + manager + (BaseUrl Https "kubernetes.default.svc" 443 "") + + +{- | The representation of a Role. -} +newtype RoleSpec = RoleSpec { + unRoleSpec :: Value + } + deriving newtype (ToJSON, FromJSON) + + +{- | The representation of a service account. -} +newtype ServiceAccountSpec = ServiceAccountSpec { + unServiceAccountSpec :: Value + } + deriving newtype (ToJSON, FromJSON) + + +{- | The representation of a Namespace specification. -} +newtype NamespaceSpec = NamespaceSpec { + unNamespaceSpec :: Value + } + deriving newtype (ToJSON, FromJSON) + +