diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/example/App.hs b/example/App.hs new file mode 100644 --- /dev/null +++ b/example/App.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Function ((&)) +import Kubernetes.Client (defaultTLSClientParams, + disableServerCertValidation, + disableServerNameValidation, + disableValidateAuthMethods, + loadPEMCerts, newManager, + setCAStore, setClientCert, + setMasterURI, setTokenAuth) +import Kubernetes.OpenAPI (Accept (..), MimeJSON (..), + dispatchMime, newConfig) +import qualified Kubernetes.OpenAPI.API.CoreV1 as CoreV1 +import Network.TLS (credentialLoadX509) + +example :: IO () +example = do + -- We need to first create a Kubernetes.Core.KubernetesConfig and a Network.HTTP.Client.Manager. + -- Currently we need to construct these objects manually. Work is underway to construct these + -- objects automatically from a kubeconfig file. See https://github.com/kubernetes-client/haskell/issues/2. + kcfg <- + newConfig + & fmap (setMasterURI "https://mycluster.example.com") -- fill in master URI + & fmap (setTokenAuth "mytoken") -- if using token auth + & fmap disableValidateAuthMethods -- if using client cert auth + myCAStore <- loadPEMCerts "/path/to/ca.crt" -- if using custom CA certs + myCert <- -- if using client cert + credentialLoadX509 "/path/to/client.crt" "/path/to/client.key" + >>= either error return + tlsParams <- + defaultTLSClientParams + & fmap disableServerNameValidation -- if master address is specified as an IP address + & fmap disableServerCertValidation -- if you don't want to validate the server cert at all (insecure) + & fmap (setCAStore myCAStore) -- if using custom CA certs + & fmap (setClientCert myCert) -- if using client cert + manager <- newManager tlsParams + dispatchMime + manager + kcfg + (CoreV1.listPodForAllNamespaces (Accept MimeJSON)) + >>= print + +main :: IO () +main = return () diff --git a/kubernetes-client.cabal b/kubernetes-client.cabal new file mode 100644 --- /dev/null +++ b/kubernetes-client.cabal @@ -0,0 +1,109 @@ +cabal-version: 1.12 +name: kubernetes-client +version: 0.1.0.0 +license: Apache-2.0 +license-file: LICENSE +maintainer: Shimin Guo +synopsis: Client library for Kubernetes +description: + Client library for interacting with a Kubernetes cluster. + . + This package contains hand-written code while kubernetes-client-core contains code auto-generated from the OpenAPI spec. +category: Web +build-type: Simple +extra-source-files: + test/testdata/kubeconfig.yaml + +library + exposed-modules: + Kubernetes.Client + Kubernetes.Client.Config + Kubernetes.Client.KubeConfig + Kubernetes.Client.Watch + hs-source-dirs: src + other-modules: + Paths_kubernetes_client + default-language: Haskell2010 + build-depends: + aeson >=1.2.2 && <1.5, + base >=4.7 && <5.0, + bytestring >=0.10.0 && <0.11, + connection >=0.2.8 && <0.3, + containers >=0.6.0.1 && <0.7, + data-default-class >=0.1.2.0 && <0.2, + http-client >=0.5 && <0.7, + http-client-tls >=0.3.5.3 && <0.4, + kubernetes-client-core ==0.1.0.1, + microlens >=0.4.3 && <0.5, + mtl >=2.2.1 && <2.3, + pem >=0.2.4 && <0.3, + safe-exceptions >=0.1.0.0 && <0.2, + streaming-bytestring >=0.1.5 && <0.2.0, + text >=0.11 && <1.3, + tls >=1.4.1 && <1.5, + x509 >=1.7.5 && <1.8, + x509-store >=1.6.7 && <1.7, + x509-system >=1.6.6 && <1.7, + x509-validation >=1.6.11 && <1.7 + +test-suite example + type: exitcode-stdio-1.0 + main-is: App.hs + hs-source-dirs: example + other-modules: + Paths_kubernetes_client + default-language: Haskell2010 + build-depends: + aeson >=1.2.2 && <1.5, + base >=4.7 && <5.0, + bytestring >=0.10.0 && <0.11, + connection >=0.2.8 && <0.3, + containers >=0.6.0.1 && <0.7, + data-default-class >=0.1.2.0 && <0.2, + http-client >=0.5 && <0.7, + http-client-tls >=0.3.5.3 && <0.4, + kubernetes-client -any, + kubernetes-client-core ==0.1.0.1, + microlens >=0.4.3 && <0.5, + mtl >=2.2.1 && <2.3, + pem >=0.2.4 && <0.3, + safe-exceptions >=0.1.0.0 && <0.2, + streaming-bytestring >=0.1.5 && <0.2.0, + text >=0.11 && <1.3, + tls >=1.4.1 && <1.5, + x509 >=1.7.5 && <1.8, + x509-store >=1.6.7 && <1.7, + x509-system >=1.6.6 && <1.7, + x509-validation >=1.6.11 && <1.7 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Paths_kubernetes_client + default-language: Haskell2010 + build-depends: + aeson >=1.2.2 && <1.5, + base >=4.7 && <5.0, + bytestring >=0.10.0 && <0.11, + connection >=0.2.8 && <0.3, + containers >=0.6.0.1 && <0.7, + data-default-class >=0.1.2.0 && <0.2, + hspec >=2.6.1 && <2.7, + http-client >=0.5 && <0.7, + http-client-tls >=0.3.5.3 && <0.4, + kubernetes-client -any, + kubernetes-client-core ==0.1.0.1, + microlens >=0.4.3 && <0.5, + mtl >=2.2.1 && <2.3, + pem >=0.2.4 && <0.3, + safe-exceptions >=0.1.0.0 && <0.2, + streaming-bytestring >=0.1.5 && <0.2.0, + text >=0.11 && <1.3, + tls >=1.4.1 && <1.5, + x509 >=1.7.5 && <1.8, + x509-store >=1.6.7 && <1.7, + x509-system >=1.6.6 && <1.7, + x509-validation >=1.6.11 && <1.7, + yaml >=0.11.0.0 && <0.12 diff --git a/src/Kubernetes/Client.hs b/src/Kubernetes/Client.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client.hs @@ -0,0 +1,9 @@ +module Kubernetes.Client + ( module Kubernetes.Client.Config + , module Kubernetes.Client.KubeConfig + , module Kubernetes.Client.Watch + ) where + +import Kubernetes.Client.Config +import Kubernetes.Client.KubeConfig +import Kubernetes.Client.Watch diff --git a/src/Kubernetes/Client/Config.hs b/src/Kubernetes/Client/Config.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Config.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Kubernetes.Client.Config where + +import qualified Kubernetes.OpenAPI.Core as K +import qualified Kubernetes.OpenAPI.Model as K + +import Control.Exception.Safe (Exception, MonadThrow, throwM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LazyB +import Data.Default.Class (def) +import Data.Either (rights) +import Data.Monoid ((<>)) +import Data.PEM (pemContent, pemParseBS) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Typeable (Typeable) +import Data.X509 (SignedCertificate, + decodeSignedCertificate) +import qualified Data.X509 as X509 +import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) +import qualified Data.X509.Validation as X509 +import Lens.Micro (Lens', lens, set) +import Network.Connection (TLSSettings (..)) +import qualified Network.HTTP.Client as NH +import Network.HTTP.Client.TLS (mkManagerSettings) +import Network.TLS (Credential, defaultParamsClient) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLS +import System.Environment (getEnv) +import System.X509 (getSystemCertificateStore) + +-- |Sets the master URI in the 'K.KubernetesClientConfig'. +setMasterURI + :: T.Text -- ^ Master URI + -> K.KubernetesClientConfig + -> K.KubernetesClientConfig +setMasterURI server kcfg = + kcfg { K.configHost = (LazyB.fromStrict . T.encodeUtf8) server } + +-- |Disables the client-side auth methods validation. This is necessary if you are using client cert authentication. +disableValidateAuthMethods :: K.KubernetesClientConfig -> K.KubernetesClientConfig +disableValidateAuthMethods kcfg = kcfg { K.configValidateAuthMethods = False } + +-- |Configures the 'K.KubernetesClientConfig' to use token authentication. +setTokenAuth + :: T.Text -- ^Authentication token + -> K.KubernetesClientConfig + -> K.KubernetesClientConfig +setTokenAuth token kcfg = kcfg + { K.configAuthMethods = [K.AnyAuthMethod (K.AuthApiKeyBearerToken $ "Bearer " <> token)] + } + +-- |Creates a 'NH.Manager' that can handle TLS. +newManager :: TLS.ClientParams -> IO NH.Manager +newManager cp = NH.newManager (mkManagerSettings (TLSSettings cp) Nothing) + +-- |Default TLS settings using the system CA store. +defaultTLSClientParams :: IO TLS.ClientParams +defaultTLSClientParams = do + let defParams = defaultParamsClient "" "" + systemCAStore <- getSystemCertificateStore + return defParams + { TLS.clientSupported = def + { TLS.supportedCiphers = TLS.ciphersuite_strong + } + , TLS.clientShared = (TLS.clientShared defParams) + { TLS.sharedCAStore = systemCAStore + } + } + +clientHooksL :: Lens' TLS.ClientParams TLS.ClientHooks +clientHooksL = lens TLS.clientHooks (\cp ch -> cp { TLS.clientHooks = ch }) + +onServerCertificateL :: Lens' TLS.ClientParams (CertificateStore -> TLS.ValidationCache -> X509.ServiceID -> X509.CertificateChain -> IO [X509.FailedReason]) +onServerCertificateL = + clientHooksL . lens TLS.onServerCertificate (\ch osc -> ch { TLS.onServerCertificate = osc }) + +-- |Don't check whether the cert presented by the server matches the name of the server you are connecting to. +-- This is necessary if you specify the server host by its IP address. +disableServerNameValidation :: TLS.ClientParams -> TLS.ClientParams +disableServerNameValidation = + set onServerCertificateL (X509.validate X509.HashSHA256 def (def { X509.checkFQHN = False })) + +-- |Insecure mode. The client will not validate the server cert at all. +disableServerCertValidation :: TLS.ClientParams -> TLS.ClientParams +disableServerCertValidation = set onServerCertificateL (\_ _ _ _ -> return []) + +-- |Use a custom CA store. +setCAStore :: [SignedCertificate] -> TLS.ClientParams -> TLS.ClientParams +setCAStore certs cp = cp + { TLS.clientShared = (TLS.clientShared cp) + { TLS.sharedCAStore = (makeCertificateStore certs) + } + } + +onCertificateRequestL :: Lens' TLS.ClientParams (([TLS.CertificateType], Maybe [TLS.HashAndSignatureAlgorithm], [X509.DistinguishedName]) -> IO (Maybe (X509.CertificateChain, TLS.PrivKey))) +onCertificateRequestL = + clientHooksL . lens TLS.onCertificateRequest (\ch ocr -> ch { TLS.onCertificateRequest = ocr }) + +-- |Use a client cert for authentication. +setClientCert :: Credential -> TLS.ClientParams -> TLS.ClientParams +setClientCert cred = set onCertificateRequestL (\_ -> return $ Just cred) + +-- |Parses a PEM-encoded @ByteString@ into a list of certificates. +parsePEMCerts :: B.ByteString -> Either String [SignedCertificate] +parsePEMCerts b = do + pems <- pemParseBS b + return $ rights $ map (decodeSignedCertificate . pemContent) pems + +data ParsePEMCertsException = ParsePEMCertsException String deriving (Typeable, Show) + +instance Exception ParsePEMCertsException + +-- |Loads certificates from a PEM-encoded file. +loadPEMCerts :: (MonadIO m, MonadThrow m) => FilePath -> m [SignedCertificate] +loadPEMCerts p = do + liftIO (B.readFile p) + >>= either (throwM . ParsePEMCertsException) return + . parsePEMCerts + +serviceAccountDir :: FilePath +serviceAccountDir = "/var/run/secrets/kubernetes.io/serviceaccount" + +cluster :: (MonadIO m, MonadThrow m) => m (NH.Manager, K.KubernetesClientConfig) +cluster = do + caStore <- loadPEMCerts $ serviceAccountDir ++ "/ca.crt" + defTlsParams <- liftIO defaultTLSClientParams + mgr <- liftIO . newManager . setCAStore caStore $ disableServerNameValidation defTlsParams + tok <- liftIO . T.readFile $ serviceAccountDir ++ "/token" + host <- liftIO $ getEnv "KUBERNETES_SERVICE_HOST" + port <- liftIO $ getEnv "KUBERNETES_SERVICE_PORT" + config <- setTokenAuth tok . setMasterURI (T.pack $ "https://" ++ host ++ ":" ++ port) <$> liftIO K.newConfig + return (mgr, config) diff --git a/src/Kubernetes/Client/KubeConfig.hs b/src/Kubernetes/Client/KubeConfig.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/KubeConfig.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Module : Kubernetes.KubeConfig +Description : Data model for the kubeconfig. + +This module contains the definition of the data model of the kubeconfig. + +The official definition of the kubeconfig is defined in https://github.com/kubernetes/client-go/blob/master/tools/clientcmd/api/v1/types.go. + +This is a mostly straightforward translation into Haskell, with 'FromJSON' and 'ToJSON' instances defined. +-} +module Kubernetes.Client.KubeConfig where + +import Data.Aeson (FromJSON (..), Options, ToJSON (..), + Value (..), camelTo2, defaultOptions, + fieldLabelModifier, genericParseJSON, + genericToJSON, object, omitNothingFields, + withObject, (.:), (.=)) +import qualified Data.Map as Map +import Data.Proxy +import Data.Semigroup ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import GHC.Generics +import GHC.TypeLits + +camelToWithOverrides :: Char -> Map.Map String String -> Options +camelToWithOverrides c overrides = defaultOptions + { fieldLabelModifier = modifier + , omitNothingFields = True + } + where modifier s = Map.findWithDefault (camelTo2 c s) s overrides + +-- |Represents a kubeconfig. +data Config = Config + { kind :: Maybe Text + , apiVersion :: Maybe Text + , preferences :: Maybe Preferences + , clusters :: [NamedEntity Cluster "cluster"] + , authInfos :: [NamedEntity AuthInfo "user"] + , contexts :: [NamedEntity Context "context"] + , currentContext :: Text + } deriving (Eq, Generic, Show) + +configJSONOptions = camelToWithOverrides + '-' + (Map.fromList [("apiVersion", "apiVersion"), ("authInfos", "users")]) + +instance ToJSON Config where + toJSON = genericToJSON configJSONOptions + +instance FromJSON Config where + parseJSON = genericParseJSON configJSONOptions + +newtype Preferences = Preferences + { colors :: Maybe Bool + } deriving (Eq, Generic, Show) + +instance ToJSON Preferences where + toJSON = genericToJSON $ camelToWithOverrides '-' Map.empty + +instance FromJSON Preferences where + parseJSON = genericParseJSON $ camelToWithOverrides '-' Map.empty + +data Cluster = Cluster + { server :: Text + , insecureSkipTLSVerify :: Maybe Bool + , certificateAuthority :: Maybe Text + , certificateAuthorityData :: Maybe Text + } deriving (Eq, Generic, Show, Typeable) + +instance ToJSON Cluster where + toJSON = genericToJSON $ camelToWithOverrides '-' Map.empty + +instance FromJSON Cluster where + parseJSON = genericParseJSON $ camelToWithOverrides '-' Map.empty + +data NamedEntity a (typeKey :: Symbol) = NamedEntity + { name :: Text + , entity :: a } deriving (Eq, Generic, Show) + +instance (FromJSON a, Typeable a, KnownSymbol s) => + FromJSON (NamedEntity a s) where + parseJSON = withObject ("Named" <> (show $ typeOf (undefined :: a))) $ \v -> + NamedEntity <$> v .: "name" <*> v .: T.pack (symbolVal (Proxy :: Proxy s)) + +instance (ToJSON a, KnownSymbol s) => + ToJSON (NamedEntity a s) where + toJSON (NamedEntity {..}) = object + ["name" .= toJSON name, T.pack (symbolVal (Proxy :: Proxy s)) .= toJSON entity] + +toMap :: [NamedEntity a s] -> Map.Map Text a +toMap = Map.fromList . fmap (\NamedEntity {..} -> (name, entity)) + +data AuthInfo = AuthInfo + { clientCertificate :: Maybe FilePath + , clientCertificateData :: Maybe Text + , clientKey :: Maybe FilePath + , clientKeyData :: Maybe Text + , token :: Maybe Text + , tokenFile :: Maybe FilePath + , impersonate :: Maybe Text + , impersonateGroups :: Maybe [Text] + , impersonateUserExtra :: Maybe (Map.Map Text [Text]) + , username :: Maybe Text + , password :: Maybe Text + , authProvider :: Maybe AuthProviderConfig + } deriving (Eq, Generic, Show, Typeable) + +authInfoJSONOptions = camelToWithOverrides + '-' + ( Map.fromList + [ ("tokenFile" , "tokenFile") + , ("impersonate" , "as") + , ("impersonateGroups" , "as-groups") + , ("impersonateUserExtra", "as-user-extra") + ] + ) + +instance ToJSON AuthInfo where + toJSON = genericToJSON authInfoJSONOptions + +instance FromJSON AuthInfo where + parseJSON = genericParseJSON authInfoJSONOptions + +data Context = Context + { cluster :: Text + , authInfo :: Text + , namespace :: Maybe Text + } deriving (Eq, Generic, Show, Typeable) + +contextJSONOptions = + camelToWithOverrides '-' (Map.fromList [("authInfo", "user")]) + +instance ToJSON Context where + toJSON = genericToJSON contextJSONOptions + +instance FromJSON Context where + parseJSON = genericParseJSON contextJSONOptions + +data AuthProviderConfig = AuthProviderConfig + { name :: Text + , config :: Maybe (Map.Map Text Text) + } deriving (Eq, Generic, Show) + +instance ToJSON AuthProviderConfig where + toJSON = genericToJSON $ camelToWithOverrides '-' Map.empty + +instance FromJSON AuthProviderConfig where + parseJSON = genericParseJSON $ camelToWithOverrides '-' Map.empty + +-- |Returns the currently active context. +getContext :: Config -> Either String Context +getContext Config {..} = + let maybeContext = Map.lookup currentContext (toMap contexts) + in case maybeContext of + Just ctx -> Right ctx + Nothing -> Left ("No context named " <> T.unpack currentContext) + +-- |Returns the currently active user. +getAuthInfo :: Config -> Either String (Text, AuthInfo) +getAuthInfo cfg@Config {..} = do + Context {..} <- getContext cfg + let maybeAuth = Map.lookup authInfo (toMap authInfos) + case maybeAuth of + Just auth -> Right (authInfo, auth) + Nothing -> Left ("No user named " <> T.unpack authInfo) + +-- |Returns the currently active cluster. +getCluster :: Config -> Either String Cluster +getCluster cfg@Config {clusters=clusters} = do + Context {cluster=clusterName} <- getContext cfg + let maybeCluster = Map.lookup clusterName (toMap clusters) + case maybeCluster of + Just cluster -> Right cluster + Nothing -> Left ("No cluster named " <> T.unpack clusterName) diff --git a/src/Kubernetes/Client/Watch.hs b/src/Kubernetes/Client/Watch.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Watch.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Client.Watch + ( WatchEvent + , eventType + , eventObject + , dispatchWatch + ) where + +import Control.Monad +import Control.Monad.Trans (lift) +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Streaming.Char8 as Q +import qualified Data.Text as T +import Kubernetes.OpenAPI.Core +import Kubernetes.OpenAPI.Client +import Kubernetes.OpenAPI.MimeTypes +import Kubernetes.OpenAPI.Model (Watch(..)) +import Network.HTTP.Client + +data WatchEvent a = WatchEvent + { _eventType :: T.Text + , _eventObject :: a + } deriving (Eq, Show) + +instance FromJSON a => FromJSON (WatchEvent a) where + parseJSON (Object x) = WatchEvent <$> x .: "type" <*> x .: "object" + parseJSON _ = fail "Expected an object" + +instance ToJSON a => ToJSON (WatchEvent a) where + toJSON x = object + [ "type" .= _eventType x + , "object" .= _eventObject x + ] + +-- | Type of the 'WatchEvent'. +eventType :: WatchEvent a -> T.Text +eventType = _eventType + +-- | Object within the 'WatchEvent'. +eventObject :: WatchEvent a -> a +eventObject = _eventObject + +{-| Dispatch a request setting watch to true. Takes a consumer function +which consumes the 'Q.ByteString' stream. Following is a simple example which +just streams to stdout. First some setup - this assumes kubernetes is accessible +at http://localhost:8001, e.g. after running /kubectl proxy/: + +@ +import qualified Data.ByteString.Streaming.Char8 as Q + +manager <- newManager defaultManagerSettings +defaultConfig <- newConfig +config = defaultConfig { configHost = "http://localhost:8001", configValidateAuthMethods = False } +request = listEndpointsForAllNamespaces (Accept MimeJSON) +@ + +Launching 'dispatchWatch' with the above we get a stream of endpoints data: + +@ + > dispatchWatch manager config request Q.stdout + {"type":\"ADDED\","object":{"kind":\"Endpoints\","apiVersion":"v1","metadata":{"name":"heapster" .... +@ +-} +dispatchWatch :: + (HasOptionalParam req Watch, MimeType accept, MimeType contentType) => + Manager + -> KubernetesClientConfig + -> KubernetesRequest req contentType resp accept + -> (Q.ByteString IO () -> IO a) + -> IO a +dispatchWatch manager config request apply = do + let watchRequest = applyOptionalParam request (Watch True) + (InitRequest req) <- _toInitRequest config watchRequest + withHTTP req manager $ \resp -> apply $ responseBody resp + +withHTTP :: + Request + -> Manager + -> (Response (Q.ByteString IO ()) -> IO a) + -> IO a +withHTTP request manager f = withResponse request manager f' + where + f' resp = do + let p = (from . brRead . responseBody) resp + f (resp {responseBody = p}) + from :: IO B.ByteString -> Q.ByteString IO () + from io = go + where + go = do + bs <- lift io + unless (B.null bs) $ do + Q.chunk bs + go diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Data.Aeson (decode, encode, parseJSON, + toJSON) +import Data.Maybe (fromJust) +import Data.Yaml (decodeFile) +import Kubernetes.Client.KubeConfig (AuthInfo (..), Cluster (..), + Config, Context (..), + getAuthInfo, getCluster, + getContext) +import Test.Hspec + +main :: IO () +main = do + config :: Config <- fromJust <$> decodeFile "test/testdata/kubeconfig.yaml" + hspec $ do + describe "FromJSON and ToJSON instances" $ do + it "roundtrips successfully" $ do + decode (encode (toJSON config)) `shouldBe` Just config + describe "getContext" $ do + it "returns the correct context" $ do + getContext config `shouldBe` (Right (Context "cluster-aaa" "user-aaa" Nothing)) + + describe "getCluster" $ do + it "returns the correct cluster" $ do + server <$> getCluster config `shouldBe` (Right "https://aaa.example.com") + + describe "getAuthInfo" $ do + it "returns the correct authInfo" $ do + fst <$> getAuthInfo config `shouldBe` (Right "user-aaa") diff --git a/test/testdata/kubeconfig.yaml b/test/testdata/kubeconfig.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/kubeconfig.yaml @@ -0,0 +1,35 @@ +apiVersion: v1 +clusters: +- cluster: + certificate-authority-data: fake-ca-data + server: https://aaa.example.com + name: cluster-aaa +- cluster: + certificate-authority-data: fake-ca-data + server: https://bbb.example.com + name: cluster-bbb +contexts: +- context: + cluster: cluster-aaa + user: user-aaa + name: aaa +- context: + cluster: cluster-bbb + user: user-bbb + name: bbb +current-context: aaa +kind: Config +preferences: {} +users: +- name: user-aaa + user: + auth-provider: + config: + access-token: fake-token + expiry: 2017-06-06 22:53:31 + expiry-key: '{.credential.token_expiry}' + token-key: '{.credential.access_token}' + name: gcp +- name: user-bbb + user: + token: fake-token