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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,163 @@ +# kubernetes-api-client + +## Example + +### Load KubeConfig file + +```haskell +import Control.Concurrent.STM (atomically, newTVar) +import Kubernetes.Client (KubeConfigSource (..), mkKubeClientConfig) +import Kubernetes.OpenAPI (Accept (..), MimeJSON (..), dispatchMime) + +import qualified Data.Map as Map +import qualified Kubernetes.OpenAPI.API.CoreV1 as CoreV1 + +main :: IO () +main = do + oidcCache <- atomically $ newTVar $ Map.fromList [] + (mgr, kcfg) <- mkKubeClientConfig oidcCache $ KubeConfigFile "/path/to/kubeconfig" + dispatchMime + mgr + kcfg + (CoreV1.listPodForAllNamespaces (Accept MimeJSON)) + >>= print +``` + +### Load InCluster Config + +```haskell +import Control.Concurrent.STM (atomically, newTVar) +import Data.Function ((&)) +import Kubernetes.Client (KubeConfigSource (..), mkKubeClientConfig) +import Kubernetes.OpenAPI (Accept (..), MimeJSON (..), dispatchMime) +import Network.TLS (credentialLoadX509) + +import qualified Data.Map as Map +import qualified Kubernetes.OpenAPI.API.CoreV1 as CoreV1 + +main :: IO () +main = do + oidcCache <- atomically $ newTVar $ Map.fromList [] + (mgr, kcfg) <- mkKubeClientConfig oidcCache KubeConfigCluster + dispatchMime + mgr + kcfg + (CoreV1.listPodForAllNamespaces (Accept MimeJSON)) + >>= print +``` + +### Load config from URL and paths + +```haskell +{-# 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) + +main :: IO () +main = 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 +``` + +## Watch Example +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`: + +```haskell +> 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: + +```haskell + > dispatchWatch manager config request Q.stdout + {"type":\"ADDED\","object":{"kind":\"Endpoints\","apiVersion":"v1","metadata":{"name":"heapster" .... +``` + +A more complex example involving some ggprocessing of the stream, the following +prints out the event types of each event. First, define functions to allow us apply +a parser to a stream: + + +```haskell +import Data.Aeson +import qualified Data.ByteString.Streaming.Char8 as Q +import Data.JsonStream.Parser +import qualified Streaming.Prelude as S + +-- | Parse the stream using the given parser. +streamParse :: + FromJSON a => + Parser a + -> Q.ByteString IO r + -> Stream (Of [a]) IO r +streamParse parser byteStream = do + byteStream & Q.lines & parseEvent parser + +-- | Parse a single event from the stream. +parseEvent :: + (FromJSON a, Monad m) => + Parser a + -> Stream (Q.ByteString m) m r + -> Stream (Of [a]) m r +parseEvent parser byteStream = S.map (parseByteString parser) (S.mapped Q.toStrict byteStream) +``` + +Next, define the parser and apply it to the stream: + +```haskell +> eventParser = value :: Parser (WatchEvent V1Endpoints) +> withResponseBody body = streamParse eventParser body & S.map (map eventType) +> dispatchWatch manager config request (S.print . withResponseBody) +[\"ADDED\"] +[\"ADDED\"] +[\"MODIFIED\"] +... +``` + +Packages in this example: + * Data.Aeson -- from [aeson](https://hackage.haskell.org/package/aeson) + * Data.ByteString.Streaming.Char8 from [streaming-bytestring](https://hackage.haskell.org/package/streaming-bytestring-0.1.5/docs/Data-ByteString-Streaming-Char8.html) + * Data.JsonStream.Parser from [json-stream](https://hackage.haskell.org/package/json-stream-0.4.1.5/docs/Data-JsonStream-Parser.html) + * Streaming.Prelude from [streaming](https://hackage.haskell.org/package/streaming-0.2.0.0/docs/Streaming-Prelude.html) diff --git a/example/App.hs b/example/App.hs new file mode 100644 --- /dev/null +++ b/example/App.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent.STM (atomically, newTVar) +import Data.Function ((&)) +import Kubernetes.Client (KubeConfigSource (..), defaultTLSClientParams, + disableServerCertValidation, + disableServerNameValidation, + disableValidateAuthMethods, mkKubeClientConfig, + loadPEMCerts, newManager, setCAStore, + setClientCert, setMasterURI, setTokenAuth) +import Kubernetes.OpenAPI (Accept (..), MimeJSON (..), dispatchMime, + newConfig) +import Network.TLS (credentialLoadX509) + +import qualified Data.Map as Map +import qualified Kubernetes.OpenAPI.API.CoreV1 as CoreV1 + +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 + +exampleWithKubeConfig :: IO () +exampleWithKubeConfig = do + oidcCache <- atomically $ newTVar $ Map.fromList [] + (mgr, kcfg) <- mkKubeClientConfig oidcCache $ KubeConfigFile "/path/to/kubeconfig" + dispatchMime + mgr + kcfg + (CoreV1.listPodForAllNamespaces (Accept MimeJSON)) + >>= print + +exampleWithInClusterConfig :: IO () +exampleWithInClusterConfig = do + oidcCache <- atomically $ newTVar $ Map.fromList [] + (mgr, kcfg) <- mkKubeClientConfig oidcCache KubeConfigCluster + dispatchMime + mgr + kcfg + (CoreV1.listPodForAllNamespaces (Accept MimeJSON)) + >>= print + +main :: IO () +main = return () diff --git a/kubernetes-api-client.cabal b/kubernetes-api-client.cabal new file mode 100644 --- /dev/null +++ b/kubernetes-api-client.cabal @@ -0,0 +1,218 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: kubernetes-api-client +version: 0.6.0.0 +synopsis: Client library for Kubernetes +description: Client library for interacting with a Kubernetes cluster. + . + This package contains hand-written code, while @kubernetes-api@ contains code auto-generated from the OpenAPI spec. + . + It was forked from the @kubernetes-client@ package. +category: Web +maintainer: Tom McLaughlin +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + test/testdata/certs/certificate.pem + test/testdata/certs/private-key.pem + test/testdata/kubeconfig.yaml + test/testdata/tokens/token1 + test/testdata/tokens/token2 + README.md + +library + exposed-modules: + Kubernetes.Client + Kubernetes.Client.Auth.Basic + Kubernetes.Client.Auth.ClientCert + Kubernetes.Client.Auth.GCP + Kubernetes.Client.Auth.Internal.Types + Kubernetes.Client.Auth.OIDC + Kubernetes.Client.Auth.Token + Kubernetes.Client.Auth.TokenFile + Kubernetes.Client.Config + Kubernetes.Client.Internal.TLSUtils + Kubernetes.Client.KubeConfig + Kubernetes.Client.Watch + Kubernetes.Data.K8sJSONPath + other-modules: + Paths_kubernetes_api_client + hs-source-dirs: + src + ghc-options: -Wall + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson >=1.2 && <3 + , attoparsec >=0.13 + , base >=4.7 && <5.0 + , base64-bytestring + , bytestring >=0.10 + , containers >=0.5 + , data-default-class >=0.1 + , either >=5.0 + , filepath >=1.4 + , hoauth2 >=1.11 && <=3 + , http-client >=0.5 && <0.8 + , http-client-tls >=0.3 + , jose-jwt >=0.8 + , jsonpath >=0.1 && <0.4 + , kubernetes-api + , megaparsec ==9.* + , microlens >=0.4 + , mtl >=2.2 + , oidc-client >=0.4 + , pem >=0.2 + , safe-exceptions >=0.1.0.0 + , stm >=2.4 + , streaming-bytestring >=0.1 && <0.4 + , text >=0.11 && <3 + , time >=1.8 + , timerep >=2.0 + , tls >=1.4.1 + , typed-process >=0.2 + , uri-bytestring >=0.3 + , yaml >=0.8.32 + default-language: Haskell2010 + if impl(ghc >= 9.6) + build-depends: + crypton-connection + , crypton-x509 >=1.7 + , crypton-x509-store >=1.6 + , crypton-x509-system >=1.6 + , crypton-x509-validation >=1.6 + else + build-depends: + connection + , x509 >=1.7 + , x509-store >=1.6 + , x509-system >=1.6 + , x509-validation >=1.6 + +test-suite example + type: exitcode-stdio-1.0 + main-is: App.hs + other-modules: + Paths_kubernetes_api_client + hs-source-dirs: + example + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson >=1.2 && <3 + , attoparsec >=0.13 + , base >=4.7 && <5.0 + , base64-bytestring + , bytestring >=0.10 + , containers >=0.5 + , data-default-class >=0.1 + , either >=5.0 + , filepath >=1.4 + , hoauth2 >=1.11 && <=3 + , http-client >=0.5 && <0.8 + , http-client-tls >=0.3 + , jose-jwt >=0.8 + , jsonpath >=0.1 && <0.4 + , kubernetes-api + , kubernetes-api-client + , megaparsec ==9.* + , microlens >=0.4 + , mtl >=2.2 + , oidc-client >=0.4 + , pem >=0.2 + , safe-exceptions >=0.1.0.0 + , stm >=2.4 + , streaming-bytestring >=0.1 && <0.4 + , text >=0.11 && <3 + , time >=1.8 + , timerep >=2.0 + , tls >=1.4.1 + , typed-process >=0.2 + , uri-bytestring >=0.3 + , yaml >=0.8.32 + default-language: Haskell2010 + if impl(ghc >= 9.6) + build-depends: + crypton-connection + , crypton-x509 >=1.7 + , crypton-x509-store >=1.6 + , crypton-x509-system >=1.6 + , crypton-x509-validation >=1.6 + else + build-depends: + connection + , x509 >=1.7 + , x509-store >=1.6 + , x509-system >=1.6 + , x509-validation >=1.6 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Kubernetes.Client.Auth.BasicSpec + Kubernetes.Client.Auth.ClientCertSpec + Kubernetes.Client.Auth.TokenFileSpec + Kubernetes.Client.KubeConfigSpec + Kubernetes.Data.K8sJSONPathSpec + Paths_kubernetes_api_client + hs-source-dirs: + test + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson >=1.2 && <3 + , attoparsec >=0.13 + , base >=4.7 && <5.0 + , base64-bytestring + , bytestring >=0.10 + , containers >=0.5 + , data-default-class >=0.1 + , either >=5.0 + , file-embed + , filepath >=1.4 + , hoauth2 >=1.11 && <=3 + , hspec + , hspec-attoparsec + , hspec-megaparsec + , http-client >=0.5 && <0.8 + , http-client-tls >=0.3 + , jose-jwt >=0.8 + , jsonpath >=0.1 && <0.4 + , kubernetes-api + , kubernetes-api-client + , megaparsec ==9.* + , microlens >=0.4 + , mtl >=2.2 + , oidc-client >=0.4 + , pem >=0.2 + , safe-exceptions >=0.1.0.0 + , stm >=2.4 + , streaming-bytestring >=0.1 && <0.4 + , text >=0.11 && <3 + , time >=1.8 + , timerep >=2.0 + , tls >=1.4.1 + , typed-process >=0.2 + , uri-bytestring >=0.3 + , yaml >=0.8.4 + default-language: Haskell2010 + if impl(ghc >= 9.6) + build-depends: + crypton-connection + , crypton-x509 >=1.7 + , crypton-x509-store >=1.6 + , crypton-x509-system >=1.6 + , crypton-x509-validation >=1.6 + else + build-depends: + connection + , x509 >=1.7 + , x509-store >=1.6 + , x509-system >=1.6 + , x509-validation >=1.6 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/Auth/Basic.hs b/src/Kubernetes/Client/Auth/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/Basic.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Kubernetes.Client.Auth.Basic where + +import Data.ByteString.Base64 ( encode ) +import Data.Function ( (&) ) +import Data.Text ( Text ) +import Kubernetes.Client.Auth.Internal.Types +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI.Core + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + +import qualified Data.Text.Encoding as T +import qualified Lens.Micro as L + + +data BasicAuth = BasicAuth { basicAuthUsername :: Text + , basicAuthPassword :: Text + } + +instance AuthMethod BasicAuth where + applyAuthMethod _ BasicAuth{..} req = + pure + $ req + `setHeader` toHeader ("authorization", "Basic " <> encodeBasicAuth) + & L.set rAuthTypesL [] + where + encodeBasicAuth = T.decodeUtf8 $ encode $ T.encodeUtf8 $ basicAuthUsername <> ":" <> basicAuthPassword + +-- |Detects if username and password is specified in AuthConfig, if it is configures 'KubernetesClientConfig' with 'BasicAuth' +basicAuth :: DetectAuth +basicAuth auth (tlsParams, cfg) = do + u <- username auth + p <- password auth + return $ return (tlsParams, setBasicAuth u p cfg) + +-- |Configures the 'KubernetesClientConfig' to use basic authentication. +setBasicAuth + :: Text -- ^Username + -> Text -- ^Password + -> KubernetesClientConfig + -> KubernetesClientConfig +setBasicAuth u p kcfg = kcfg + { configAuthMethods = [AnyAuthMethod (BasicAuth u p)] + } diff --git a/src/Kubernetes/Client/Auth/ClientCert.hs b/src/Kubernetes/Client/Auth/ClientCert.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/ClientCert.hs @@ -0,0 +1,41 @@ +module Kubernetes.Client.Auth.ClientCert where + +import Control.Exception.Safe (Exception, throwM) +import Data.Text.Encoding +import Kubernetes.Client.Auth.Internal.Types +import Kubernetes.Client.Internal.TLSUtils +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI (KubernetesClientConfig (..)) +import Network.TLS + +-- | Detects if kuebconfig file provides 'client-certificate', if it configures TLS client params with the client certificate +clientCertFileAuth :: DetectAuth +clientCertFileAuth auth (tlsParams, cfg) = do + certFile <- clientCertificate auth + keyFile <- clientKey auth + return $ do + cert <- credentialLoadX509 certFile keyFile + >>= either (throwM . CredentialLoadException) return + let newParams = (setClientCert cert tlsParams) + newCfg = (disableValidateAuthMethods cfg) + return (newParams, newCfg) + +-- | Detects if kuebconfig file provides 'client-certificate-data', if it configures TLS client params with the client certificate +clientCertDataAuth :: DetectAuth +clientCertDataAuth auth (tlsParams, cfg) = do + certB64 <- encodeUtf8 <$> clientCertificateData auth + keyB64 <- encodeUtf8 <$> clientKeyData auth + Just $ do + cert <- loadB64EncodedCert certB64 keyB64 + let newParams = (setClientCert cert tlsParams) + newCfg = (disableValidateAuthMethods cfg) + return (newParams, newCfg) + +-- |Disables the client-side auth methods validation. This is necessary if you are using client cert authentication. +disableValidateAuthMethods :: KubernetesClientConfig -> KubernetesClientConfig +disableValidateAuthMethods kcfg = kcfg { configValidateAuthMethods = False } + +data CredentialLoadException = CredentialLoadException String + deriving Show + +instance Exception CredentialLoadException diff --git a/src/Kubernetes/Client/Auth/GCP.hs b/src/Kubernetes/Client/Auth/GCP.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/GCP.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Kubernetes.Client.Auth.GCP + ( gcpAuth ) +where + +import Control.Concurrent.STM +import Control.Exception.Safe (Exception, throwM) +import Data.Either.Combinators +import Data.Function ((&)) +import Data.JSONPath +import Data.Map (Map) +import Data.Text (Text) +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC3339 +import Kubernetes.Client.Auth.Internal.Types +import Kubernetes.Client.KubeConfig +import Kubernetes.Data.K8sJSONPath +import Kubernetes.OpenAPI.Core +import System.Process.Typed + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + +import qualified Data.Aeson as Aeson +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Lens.Micro as L + +-- TODO: Add support for scopes based token fetching +data GCPAuth = GCPAuth { gcpAccessToken :: TVar(Maybe Text) + , gcpTokenExpiry :: TVar(Maybe UTCTime) + , gcpCmd :: ProcessConfig () () () + , gcpTokenKey :: [K8sPathElement] + , gcpExpiryKey :: [K8sPathElement] + } + +instance AuthMethod GCPAuth where + applyAuthMethod _ gcp req = do + token <- getToken gcp + >>= either throwM pure + pure + $ setHeader req [("Authorization", "Bearer " <> (Text.encodeUtf8 token))] + & L.set rAuthTypesL [] + +-- |Detects if auth-provier name is gcp, if it is configures the 'KubernetesClientConfig' with GCPAuth 'AuthMethod' +gcpAuth :: DetectAuth +gcpAuth AuthInfo{authProvider = Just(AuthProviderConfig "gcp" (Just cfg))} (tlsParams, kubecfg) + = Just $ do + configOrErr <- parseGCPAuthInfo cfg + case configOrErr of + Left err -> throwM err + Right gcp -> pure (tlsParams, addAuthMethod kubecfg gcp) +gcpAuth _ _ = Nothing + +data GCPAuthParsingException = GCPAuthMissingInformation String + | GCPAuthInvalidExpiry String + | GCPAuthInvalidTokenJSONPath String + | GCPAuthInvalidExpiryJSONPath String + deriving Show +instance Exception GCPAuthParsingException + +data GCPGetTokenException = GCPCmdProducedInvalidJSON String + | GCPTokenNotFound String + | GCPTokenExpiryNotFound String + | GCPTokenExpiryInvalid String + deriving Show +instance Exception GCPGetTokenException + +getToken :: GCPAuth -> IO (Either GCPGetTokenException Text) +getToken auth@(GCPAuth{}) = getCurrentToken auth >>= maybe (fetchToken auth) (return . Right) + +getCurrentToken :: GCPAuth -> IO (Maybe Text) +getCurrentToken (GCPAuth{..}) = do + now <- getCurrentTime + maybeExpiry <- readTVarIO gcpTokenExpiry + maybeToken <- readTVarIO gcpAccessToken + return $ do + expiry <- maybeExpiry + if expiry > now + then maybeToken + else Nothing + +fetchToken :: GCPAuth -> IO (Either GCPGetTokenException Text) +fetchToken GCPAuth{..} = do + (stdOut, _) <- readProcess_ gcpCmd + case parseTokenAndExpiry stdOut of + Left err -> return $ Left err + Right (token, expiry) -> do + atomically $ do + writeTVar gcpAccessToken (Just token) + writeTVar gcpTokenExpiry (Just expiry) + return $ Right token + where + parseTokenAndExpiry credsStr = do + credsJSON <- Aeson.eitherDecode credsStr + & mapLeft GCPCmdProducedInvalidJSON + token <- runJSONPath gcpTokenKey credsJSON + & mapLeft GCPTokenNotFound + expText <- runJSONPath gcpExpiryKey credsJSON + & mapLeft GCPTokenExpiryNotFound + expiry <- parseExpiryTime expText + & mapLeft GCPTokenExpiryInvalid + return (token, expiry) + +parseGCPAuthInfo :: Map Text Text -> IO (Either GCPAuthParsingException GCPAuth) +parseGCPAuthInfo authInfo = do + gcpAccessToken <- atomically $ newTVar $ Map.lookup "access-token" authInfo + eitherGCPExpiryToken <- sequence $ fmap (atomically . newTVar) lookupAndParseExpiry + return $ do + gcpTokenExpiry <- mapLeft GCPAuthInvalidExpiry eitherGCPExpiryToken + cmdPath <- Text.unpack <$> lookupEither "cmd-path" + cmdArgs <- Text.splitOn " " <$> lookupEither "cmd-args" + gcpTokenKey <- readJSONPath "token-key" [JSONPath [KeyChild "token_expiry"]] + & mapLeft GCPAuthInvalidTokenJSONPath + gcpExpiryKey <- readJSONPath "expiry-key" [JSONPath [KeyChild "access_token"]] + & mapLeft GCPAuthInvalidExpiryJSONPath + let gcpCmd = proc cmdPath (map Text.unpack cmdArgs) + pure $ GCPAuth{..} + where + lookupAndParseExpiry = + case Map.lookup "expiry" authInfo of + Nothing -> Right Nothing + Just expiryText -> Just <$> parseExpiryTime expiryText + lookupEither key = Map.lookup key authInfo + & maybeToRight (GCPAuthMissingInformation $ Text.unpack key) + readJSONPath key defaultPath = + maybe (Right defaultPath) parseK8sJSONPath $ Map.lookup key authInfo + +parseExpiryTime :: Text -> Either String UTCTime +parseExpiryTime expiryText = + zonedTimeToUTC <$> parseTimeRFC3339 expiryText + & maybeToRight ("failed to parse token expiry time " <> Text.unpack expiryText) diff --git a/src/Kubernetes/Client/Auth/Internal/Types.hs b/src/Kubernetes/Client/Auth/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/Internal/Types.hs @@ -0,0 +1,9 @@ +module Kubernetes.Client.Auth.Internal.Types where + +import Network.TLS as TLS +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI (KubernetesClientConfig) + +type DetectAuth = AuthInfo + -> (TLS.ClientParams, KubernetesClientConfig) + -> Maybe (IO (TLS.ClientParams, KubernetesClientConfig)) diff --git a/src/Kubernetes/Client/Auth/OIDC.hs b/src/Kubernetes/Client/Auth/OIDC.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/OIDC.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Kubernetes.Client.Auth.OIDC + (oidcAuth, OIDCCache, cachedOIDCAuth) +where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Exception.Safe (Exception, throwM) +import Control.Monad.Except (runExceptT) +import Data.Either.Combinators +import Data.Function ((&)) +import Data.Map (Map) +import Data.Maybe +import Data.Text +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Jose.Jwt +import Kubernetes.Client.Auth.Internal.Types +import Kubernetes.Client.Internal.TLSUtils +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI.Core +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.OAuth.OAuth2 as OAuth +import Network.TLS as TLS +import URI.ByteString +import Web.OIDC.Client.Discovery as OIDC + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Lens.Micro as L + +#if !MIN_VERSION_hoauth2(2,8,0) +import qualified Network.OAuth.OAuth2.TokenRequest as OAuth2TokenRequest +#endif + + +data OIDCAuth = OIDCAuth { issuerURL :: Text + , clientID :: Text + , clientSecret :: Text + , tlsParams :: TLS.ClientParams + , idTokenTVar :: TVar(Maybe Text) + , refreshTokenTVar :: TVar(Maybe Text) +#if MIN_VERSION_hoauth2(2,3,0) + , redirectUri :: URI +#endif + } + +-- | Cache OIDCAuth based on issuerURL and clientID. +type OIDCCache = TVar (Map (Text, Text) OIDCAuth) + +instance AuthMethod OIDCAuth where + applyAuthMethod _ oidc req = do + token <- getToken oidc + pure + $ setHeader req [("Authorization", "Bearer " <> (Text.encodeUtf8 token))] + & L.set rAuthTypesL [] + +data OIDCGetTokenException = +#if MIN_VERSION_hoauth2(2,9,0) + OIDCOAuthException TokenResponseError +#elif MIN_VERSION_hoauth2(2,8,0) + OIDCOAuthException TokenRequestError +#else + OIDCOAuthException (OAuth2Error OAuth2TokenRequest.Errors) +#endif + | OIDCURIException URIParseError + | OIDCGetTokenException String + deriving Show +instance Exception OIDCGetTokenException + +data OIDCAuthParsingException = OIDCAuthCAParsingFailed ParseCertException + | OIDCAuthMissingInformation String + deriving Show +instance Exception OIDCAuthParsingException + +-- TODO: Consider a token expired few seconds before actual expiry to account for time skew +getToken :: OIDCAuth -> IO Text +getToken auth@(OIDCAuth{..}) = do + now <- getPOSIXTime + maybeIdToken <- readTVarIO idTokenTVar + case maybeIdToken of + Nothing -> fetchToken auth + Just idToken -> do + let maybeExpiry = do + (_, claims) <- decodeClaims (Text.encodeUtf8 idToken) + & rightToMaybe + jwtExp claims + case maybeExpiry of + Nothing -> fetchToken auth + Just (IntDate expiryDate) -> + if now < expiryDate + then pure idToken + else fetchToken auth + +fetchToken :: OIDCAuth -> IO Text +fetchToken auth@(OIDCAuth{..}) = do + mgr <- newManager tlsManagerSettings + maybeToken <- readTVarIO refreshTokenTVar + case maybeToken of + Nothing -> throwM $ OIDCGetTokenException "cannot refresh id-token without a refresh token" + Just token -> do + tokenEndpoint <- fetchTokenEndpoint mgr auth + tokenURI <- parseURI strictURIParserOptions (Text.encodeUtf8 tokenEndpoint) + & either (throwM . OIDCURIException) pure + +#if MIN_VERSION_hoauth2(2,3,0) + let oauth = OAuth2{ oauth2ClientId = clientID + , oauth2ClientSecret = clientSecret + , oauth2AuthorizeEndpoint = tokenURI + , oauth2TokenEndpoint = tokenURI + , oauth2RedirectUri = redirectUri + } +#elif MIN_VERSION_hoauth2(2,2,0) + let oauth = OAuth2{ oauth2ClientId = clientID + , oauth2ClientSecret = clientSecret + , oauth2AuthorizeEndpoint = tokenURI + , oauth2TokenEndpoint = tokenURI + , oauth2RedirectUri = Nothing + } +#elif MIN_VERSION_hoauth2(2,0,0) + let oauth = OAuth2{ oauth2ClientId = clientID + , oauth2ClientSecret = Just clientSecret + , oauth2AuthorizeEndpoint = tokenURI + , oauth2TokenEndpoint = tokenURI + , oauth2RedirectUri = Nothing + } +#else + let oauth = OAuth2{ oauthClientId = clientID + , oauthClientSecret = Just clientSecret + , oauthAccessTokenEndpoint = tokenURI + , oauthOAuthorizeEndpoint = tokenURI + , oauthCallback = Nothing + } +#endif + +#if MIN_VERSION_hoauth2(2,2,0) + oauthToken <- runExceptT (refreshAccessToken mgr oauth (RefreshToken token)) >>= either (throwM . OIDCOAuthException) pure +#else + oauthToken <- (refreshAccessToken mgr oauth (RefreshToken token)) >>= either (throwM . OIDCOAuthException) pure +#endif + + case OAuth.idToken oauthToken of + Nothing -> throwM $ OIDCGetTokenException "token response did not contain an id_token, either the scope \"openid\" wasn't requested upon login, or the provider doesn't support id_tokens as part of the refresh response." + Just (IdToken t) -> do + _ <- atomically $ writeTVar idTokenTVar (Just t) + return t + +fetchTokenEndpoint :: Manager -> OIDCAuth -> IO Text +fetchTokenEndpoint mgr OIDCAuth{..} = do + discover issuerURL mgr + & (fmap configuration) + & (fmap tokenEndpoint) + +{- + Detects if auth-provier name is oidc, if it is configures the 'KubernetesClientConfig' with OIDCAuth 'AuthMethod'. + Does not use cache, consider using 'cachedOIDCAuth'. +-} +oidcAuth :: DetectAuth +oidcAuth AuthInfo{authProvider = Just(AuthProviderConfig "oidc" (Just cfg))} (tls, kubecfg) + = Just + $ parseOIDCAuthInfo cfg + >>= either throwM (\oidc -> pure (tls, addAuthMethod kubecfg oidc)) +oidcAuth _ _ = Nothing + +-- TODO: Consider doing this whole function atomically, as two threads may miss the cache simultaneously +{- + Detects if auth-provier name is oidc, if it is configures the 'KubernetesClientConfig' with OIDCAuth 'AuthMethod'. + First looks for Auth information to be present in 'OIDCCache'. If found returns that, otherwise creates new Auth information and persists it in cache. +-} +cachedOIDCAuth :: OIDCCache -> DetectAuth +cachedOIDCAuth cache AuthInfo{authProvider = Just(AuthProviderConfig "oidc" (Just cfg))} (tls, kubecfg) = Just $ do + latestCache <- readTVarIO cache + issuerURL <- lookupOrThrow "idp-issuer-url" + clientID <- lookupOrThrow "client-id" + case Map.lookup (issuerURL, clientID) latestCache of + Just cacheHit -> return $ newTLSAndAuth cacheHit + Nothing -> do + parsedAuth <- parseOIDCAuthInfo cfg + >>= either throwM pure + let newCache = Map.insert (issuerURL, clientID) parsedAuth latestCache + _ <- atomically $ swapTVar cache newCache + return $ newTLSAndAuth parsedAuth + where lookupOrThrow k = Map.lookup k cfg + & maybe (throwM $ OIDCAuthMissingInformation $ Text.unpack k) pure + newTLSAndAuth auth = (tls, addAuthMethod kubecfg auth) +cachedOIDCAuth _ _ _ = Nothing + +parseOIDCAuthInfo :: Map Text Text -> IO (Either OIDCAuthParsingException OIDCAuth) +parseOIDCAuthInfo authInfo = do + eitherTLSParams <- parseCA authInfo + idTokenTVar <- atomically $ newTVar $ Map.lookup "id-token" authInfo + refreshTokenTVar <- atomically $ newTVar $ Map.lookup "refresh-token" authInfo + +#if MIN_VERSION_hoauth2(2,3,0) + redirectUri <- case Map.lookup "redirect-uri" authInfo of + Nothing -> throwM $ OIDCAuthMissingInformation "redirect-uri" + Just raw -> case parseURI laxURIParserOptions $ encodeUtf8 raw of + Left err -> throwM $ OIDCAuthMissingInformation ("Couldn't parse redirect URI: " <> show err) + Right x -> return x +#endif + + return $ do + tlsParams <- mapLeft OIDCAuthCAParsingFailed eitherTLSParams + issuerURL <- lookupEither "idp-issuer-url" + clientID <- lookupEither "client-id" + clientSecret <- lookupEither "client-secret" + return OIDCAuth{..} + where lookupEither k = Map.lookup k authInfo + & maybeToRight (OIDCAuthMissingInformation $ Text.unpack k) + +parseCA :: Map Text Text -> IO (Either ParseCertException TLS.ClientParams) +parseCA authInfo = do + tlsParams <- defaultTLSClientParams + let maybeNewParams = (parseCAFile tlsParams authInfo + <|> parseCAData tlsParams authInfo) + fromMaybe (pure $ Right tlsParams) maybeNewParams + +parseCAFile :: TLS.ClientParams -> Map Text Text -> Maybe (IO (Either ParseCertException TLS.ClientParams)) +parseCAFile tlsParams authInfo = do + caFile <- Text.unpack <$> Map.lookup "idp-certificate-authority" authInfo + Just $ do + caText <- BS.readFile caFile + return $ updateClientParams tlsParams caText + +parseCAData :: TLS.ClientParams -> Map Text Text -> Maybe (IO (Either ParseCertException TLS.ClientParams)) +parseCAData tlsParams authInfo = do + caBase64 <- Map.lookup "idp-certificate-authority-data" authInfo + Just $ pure $ do + caText <- B64.decode (Text.encodeUtf8 caBase64) + & mapLeft Base64ParsingFailed + updateClientParams tlsParams caText diff --git a/src/Kubernetes/Client/Auth/Token.hs b/src/Kubernetes/Client/Auth/Token.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/Token.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Client.Auth.Token where + +import Kubernetes.Client.Auth.Internal.Types +import Kubernetes.Client.KubeConfig ( AuthInfo(..) ) +import Kubernetes.OpenAPI.Core ( AnyAuthMethod(..) + , KubernetesClientConfig(..) + ) +import Kubernetes.OpenAPI.Model ( AuthApiKeyBearerToken(..) ) + +import qualified Data.Text as T + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ( (<>) ) +#endif + + +-- |Detects if token is specified in AuthConfig, if it is configures 'KubernetesClientConfig' with 'AuthApiKeyBearerToken' +tokenAuth :: DetectAuth +tokenAuth auth (tlsParams, cfg) = do + t <- token auth + return $ return (tlsParams, setTokenAuth t cfg) + +-- |Configures the 'KubernetesClientConfig' to use token authentication. +setTokenAuth + :: T.Text -- ^Authentication token + -> KubernetesClientConfig + -> KubernetesClientConfig +setTokenAuth t kcfg = kcfg + { configAuthMethods = [AnyAuthMethod (AuthApiKeyBearerToken $ "Bearer " <> t)] + } diff --git a/src/Kubernetes/Client/Auth/TokenFile.hs b/src/Kubernetes/Client/Auth/TokenFile.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Auth/TokenFile.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Client.Auth.TokenFile where + +import Control.Concurrent.STM +import Data.Function ( (&) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time.Clock +import Kubernetes.Client.Auth.Internal.Types +import Kubernetes.Client.KubeConfig hiding ( token ) +import Kubernetes.OpenAPI.Core +import qualified Lens.Micro as L + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ( (<>) ) +#endif + + +data TokenFileAuth = TokenFileAuth { token :: TVar(Maybe Text) + , expiry :: TVar(Maybe UTCTime) + , file :: FilePath + , period :: NominalDiffTime + } + +instance AuthMethod TokenFileAuth where + applyAuthMethod _ tokenFile req = do + t <- getToken tokenFile + pure + $ req + `setHeader` toHeader ("authorization", "Bearer " <> t) + & L.set rAuthTypesL [] + +-- |Detects if token-file is specified in AuthConfig. +tokenFileAuth :: DetectAuth +tokenFileAuth auth (tlsParams, cfg) = do + file <- tokenFile auth + return $ do + c <- setTokenFileAuth file cfg + return (tlsParams, c) + +-- |Configures the 'KubernetesClientConfig' to use TokenFile authentication. +setTokenFileAuth + :: FilePath -> KubernetesClientConfig -> IO KubernetesClientConfig +setTokenFileAuth f kcfg = atomically $ do + t <- newTVar (Nothing :: Maybe Text) + e <- newTVar (Nothing :: Maybe UTCTime) + return kcfg + { configAuthMethods = + [ AnyAuthMethod + (TokenFileAuth { token = t, expiry = e, file = f, period = 60 }) + ] + } + +getToken :: TokenFileAuth -> IO Text +getToken auth = getCurrentToken auth >>= maybe (reloadToken auth) return + +getCurrentToken :: TokenFileAuth -> IO (Maybe Text) +getCurrentToken TokenFileAuth { token, expiry } = do + now <- getCurrentTime + maybeExpiry <- readTVarIO expiry + maybeToken <- readTVarIO token + return $ do + e <- maybeExpiry + if e > now then maybeToken else Nothing + +reloadToken :: TokenFileAuth -> IO Text +reloadToken TokenFileAuth { token, expiry, file, period } = do + content <- T.readFile file + let t = T.strip content + now <- getCurrentTime + atomically $ do + writeTVar token (Just t) + writeTVar expiry (Just (addUTCTime period now)) + return t 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,176 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Kubernetes.Client.Config + ( KubeConfigSource(..) + , addCACertData + , addCACertFile + , applyAuthSettings + , clientHooksL + , defaultTLSClientParams + , disableServerCertValidation + , disableServerNameValidation + , disableValidateAuthMethods + , loadPEMCerts + , mkInClusterClientConfig + , mkKubeClientConfig + , newManager + , onCertificateRequestL + , onServerCertificateL + , parsePEMCerts + , serviceAccountDir + , setCAStore + , setClientCert + , setMasterURI + , setTokenAuth + , tlsValidation + ) +where + +import qualified Kubernetes.OpenAPI.Core as K + +import Control.Applicative ( (<|>) ) +import Control.Exception.Safe ( MonadThrow + , throwM + ) +import Control.Monad.IO.Class ( MonadIO + , liftIO + ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as LazyB +import Data.Either.Combinators +import Data.Function ( (&) ) +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Yaml +import Kubernetes.Client.Auth.Basic +import Kubernetes.Client.Auth.ClientCert +import Kubernetes.Client.Auth.GCP +import Kubernetes.Client.Auth.OIDC +import Kubernetes.Client.Auth.Token +import Kubernetes.Client.Auth.TokenFile +import Kubernetes.Client.Internal.TLSUtils +import Kubernetes.Client.KubeConfig +import Network.Connection ( TLSSettings(..) ) +import qualified Network.HTTP.Client as NH +import Network.HTTP.Client.TLS ( mkManagerSettings ) +import qualified Network.TLS as TLS +import System.Environment ( getEnv ) +import System.FilePath + +data KubeConfigSource = KubeConfigFile FilePath + | KubeConfigCluster + +{-| + Creates 'NH.Manager' and 'K.KubernetesClientConfig' for a given + 'KubeConfigSource'. It is recommended that multiple 'kubeClient' invocations + across an application share an 'OIDCCache', this makes sure updation of OAuth + token is synchronized across all the different clients being used. +-} +mkKubeClientConfig + :: OIDCCache -> KubeConfigSource -> IO (NH.Manager, K.KubernetesClientConfig) +mkKubeClientConfig oidcCache (KubeConfigFile f) = do + kubeConfig <- decodeFileThrow f + masterURI <- + server + <$> getCluster kubeConfig + & either (const $ pure "localhost:8080") return + tlsParams <- configureTLSParams kubeConfig (takeDirectory f) + clientConfig <- K.newConfig & fmap (setMasterURI masterURI) + (tlsParamsWithAuth, clientConfigWithAuth) <- case getAuthInfo kubeConfig of + Left _ -> return (tlsParams, clientConfig) + Right (_, auth) -> + applyAuthSettings oidcCache auth (tlsParams, clientConfig) + mgr <- newManager tlsParamsWithAuth + return (mgr, clientConfigWithAuth) +mkKubeClientConfig _ KubeConfigCluster = mkInClusterClientConfig + +-- |Creates 'NH.Manager' and 'K.KubernetesClientConfig' assuming it is being executed in a pod +mkInClusterClientConfig + :: (MonadIO m, MonadThrow m) => m (NH.Manager, K.KubernetesClientConfig) +mkInClusterClientConfig = do + caStore <- loadPEMCerts $ serviceAccountDir ++ "/ca.crt" + defTlsParams <- liftIO defaultTLSClientParams + mgr <- liftIO . newManager . setCAStore caStore $ disableServerNameValidation + defTlsParams + host <- liftIO $ getEnv "KUBERNETES_SERVICE_HOST" + port <- liftIO $ getEnv "KUBERNETES_SERVICE_PORT" + cfg <- setMasterURI (T.pack $ "https://" ++ host ++ ":" ++ port) <$> liftIO + (K.newConfig >>= setTokenFileAuth (serviceAccountDir ++ "/token")) + return (mgr, cfg) + +-- |Sets the master URI in the 'K.KubernetesClientConfig'. +setMasterURI + :: T.Text -- ^ Master URI + -> K.KubernetesClientConfig + -> K.KubernetesClientConfig +setMasterURI masterURI kcfg = + kcfg { K.configHost = (LazyB.fromStrict . T.encodeUtf8) masterURI } + +-- |Creates a 'NH.Manager' that can handle TLS. +newManager :: TLS.ClientParams -> IO NH.Manager +newManager cp = NH.newManager (mkManagerSettings (TLSSettings cp) Nothing) + +serviceAccountDir :: FilePath +serviceAccountDir = "/var/run/secrets/kubernetes.io/serviceaccount" + +configureTLSParams :: Config -> FilePath -> IO TLS.ClientParams +configureTLSParams cfg dir = do + defaultTLS <- defaultTLSClientParams + withCACertData <- addCACertData cfg defaultTLS + withCACertFile <- addCACertFile cfg dir withCACertData + return $ tlsValidation cfg withCACertFile + +tlsValidation :: Config -> TLS.ClientParams -> TLS.ClientParams +tlsValidation cfg tlsParams = case getCluster cfg of + Left _ -> tlsParams + Right c -> case insecureSkipTLSVerify c of + Just True -> disableServerCertValidation tlsParams + _ -> tlsParams + +addCACertData + :: (MonadThrow m) => Config -> TLS.ClientParams -> m TLS.ClientParams +addCACertData cfg tlsParams = + let + eitherCertText = + getCluster cfg + & (>>= (maybeToRight "cert data not provided" . certificateAuthorityData + ) + ) + in case eitherCertText of + Left _ -> pure tlsParams + Right certBase64 -> do + certText <- + B64.decode (T.encodeUtf8 certBase64) + & either (throwM . Base64ParsingFailed) pure + updateClientParams tlsParams certText & either throwM return + +addCACertFile :: Config -> FilePath -> TLS.ClientParams -> IO TLS.ClientParams +addCACertFile cfg dir tlsParams = do + let eitherCertFile = + getCluster cfg + >>= maybeToRight "cert file not provided" + . certificateAuthority + & fmap T.unpack + & fmap (dir ) + case eitherCertFile of + Left _ -> return tlsParams + Right certFile -> do + certText <- B.readFile certFile + return $ updateClientParams tlsParams certText & fromRight tlsParams + +applyAuthSettings + :: OIDCCache + -> AuthInfo + -> (TLS.ClientParams, K.KubernetesClientConfig) + -> IO (TLS.ClientParams, K.KubernetesClientConfig) +applyAuthSettings oidcCache auth input = + fromMaybe (pure input) + $ clientCertFileAuth auth input + <|> clientCertDataAuth auth input + <|> tokenAuth auth input + <|> tokenFileAuth auth input + <|> gcpAuth auth input + <|> cachedOIDCAuth oidcCache auth input + <|> basicAuth auth input diff --git a/src/Kubernetes/Client/Internal/TLSUtils.hs b/src/Kubernetes/Client/Internal/TLSUtils.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Client/Internal/TLSUtils.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Client.Internal.TLSUtils where + +import Control.Exception.Safe (Exception, MonadThrow, throwM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.Default.Class (def) +import Data.Either (rights) +import Data.Either.Combinators (mapLeft) +import Data.PEM (pemContent, pemParseBS) +import Data.X509 (SignedCertificate, decodeSignedCertificate) +import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) +import Lens.Micro ((&), (.~), Lens', lens, set) +import Network.TLS (Credential, credentialLoadX509FromMemory, defaultParamsClient) +import System.X509 (getSystemCertificateStore) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.X509 as X509 +import qualified Data.X509.Validation as X509 +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLS + +-- |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 + } + } + +-- |Parses a PEM-encoded @ByteString@ into a list of certificates. +parsePEMCerts :: B.ByteString -> Either ParseCertException [SignedCertificate] +parsePEMCerts pemBS = do + pems <- pemParseBS pemBS + & mapLeft PEMParsingFailed + return $ rights $ map (decodeSignedCertificate . pemContent) pems + +-- | Updates client params, sets CA store to passed bytestring of CA certificates +updateClientParams :: TLS.ClientParams -> ByteString -> Either ParseCertException TLS.ClientParams +updateClientParams cp certText = parsePEMCerts certText + & (fmap (flip setCAStore cp)) + +-- |Use a custom CA store. +setCAStore :: [SignedCertificate] -> TLS.ClientParams -> TLS.ClientParams +setCAStore certs tlsParams = + tlsParams & clientSharedL . sharedCAStoreL .~ makeCertificateStore certs + +-- |Use a client cert for authentication. +setClientCert :: Credential -> TLS.ClientParams -> TLS.ClientParams +setClientCert cred = set onCertificateRequestL (\_ -> return $ Just cred) + +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 }) + +clientSharedL :: Lens' TLS.ClientParams TLS.Shared +clientSharedL = lens TLS.clientShared (\tlsParams cs -> tlsParams {TLS.clientShared = cs} ) + +sharedCAStoreL :: Lens' TLS.Shared CertificateStore +sharedCAStoreL = lens TLS.sharedCAStore (\shared store -> shared{TLS.sharedCAStore = store}) + +-- |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 []) + +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 }) + +-- |Loads certificates from a PEM-encoded file. +loadPEMCerts :: (MonadIO m, MonadThrow m) => FilePath -> m [SignedCertificate] +loadPEMCerts pemFile = do + liftIO (B.readFile pemFile) + >>= (either throwM return) + . parsePEMCerts + +-- |Loads Base64 encoded certificate and private key +loadB64EncodedCert :: (MonadThrow m) => B.ByteString -> B.ByteString -> m Credential +loadB64EncodedCert certB64 keyB64 = either throwM pure $ do + certText <- B64.decode certB64 + & mapLeft Base64ParsingFailed + keyText <- B64.decode keyB64 + & mapLeft Base64ParsingFailed + credentialLoadX509FromMemory certText keyText + & mapLeft FailedToLoadCredential + +data ParseCertException = PEMParsingFailed String + | Base64ParsingFailed String + | FailedToLoadCredential String + deriving Show + +instance Exception ParseCertException 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,204 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +{-| +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 (..), + camelTo2, defaultOptions, + fieldLabelModifier, genericParseJSON, + genericToJSON, object, omitNothingFields, + withObject, (.:), (.=)) +import qualified Data.Map as Map +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import GHC.Generics +import GHC.TypeLits + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as A +#endif + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + + +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 :: Options +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 -> +#if MIN_VERSION_aeson(2,0,0) + NamedEntity <$> v .: "name" <*> v .: A.fromString (symbolVal (Proxy :: Proxy s)) +#else + NamedEntity <$> v .: "name" <*> v .: T.pack (symbolVal (Proxy :: Proxy s)) +#endif + +instance (ToJSON a, KnownSymbol s) => + ToJSON (NamedEntity a s) where + toJSON (NamedEntity {..}) = object +#if MIN_VERSION_aeson(2,0,0) + ["name" .= toJSON name, A.fromString (symbolVal (Proxy :: Proxy s)) .= toJSON entity] +#else + ["name" .= toJSON name, T.pack (symbolVal (Proxy :: Proxy s)) .= toJSON entity] +#endif + +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 :: Options +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 :: Options +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,105 @@ +{-# LANGUAGE CPP #-} +{-# 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.Text as T +import Kubernetes.OpenAPI.Client +import Kubernetes.OpenAPI.Core +import Kubernetes.OpenAPI.MimeTypes +import Kubernetes.OpenAPI.Model (Watch(..)) +import Network.HTTP.Client + +#if MIN_VERSION_streaming_bytestring(0,1,7) +import qualified Streaming.ByteString.Char8 as Q +type ByteStream = Q.ByteStream +#else +import qualified Data.ByteString.Streaming.Char8 as Q +type ByteStream = Q.ByteString +#endif + + +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 + -> (ByteStream 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 (ByteStream 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 -> ByteStream IO () + from io = go + where + go = do + bs <- lift io + unless (B.null bs) $ do + Q.chunk bs + go diff --git a/src/Kubernetes/Data/K8sJSONPath.hs b/src/Kubernetes/Data/K8sJSONPath.hs new file mode 100644 --- /dev/null +++ b/src/Kubernetes/Data/K8sJSONPath.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Data.K8sJSONPath where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.Text +import Data.Bifunctor +import Data.JSONPath +import Data.Text as Text +import Data.Text.Lazy (toStrict) + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + +#if MIN_VERSION_jsonpath(0,3,0) +import Data.Void (Void) +import Text.Megaparsec ( Parsec, eof, runParser, some, takeWhile1P ) +import Text.Megaparsec.Char ( char ) +type Parser a = Parsec Void Text a +#else +import Data.Attoparsec.Text ( Parser, char, endOfInput, many1, parseOnly, takeWhile1 ) +#endif + + +data K8sPathElement = PlainText Text + | JSONPath [JSONPathElement] + deriving (Show, Eq) + +parseK8sJSONPath :: Text -> Either String [K8sPathElement] +#if MIN_VERSION_jsonpath(0,3,0) +parseK8sJSONPath = first show . runParser (k8sJSONPath <* eof) "nothing" +#else +parseK8sJSONPath = parseOnly (k8sJSONPath <* endOfInput) +#endif + +k8sJSONPath :: Parser [K8sPathElement] +#if MIN_VERSION_jsonpath(0,3,0) +k8sJSONPath = some pathElementParser +#else +k8sJSONPath = many1 pathElementParser +#endif + +pathElementParser :: Parser K8sPathElement +pathElementParser = jsonpathParser <|> plainTextParser + +plainTextParser :: Parser K8sPathElement +#if MIN_VERSION_jsonpath(0,3,0) +plainTextParser = PlainText <$> takeWhile1P (Just "non_open_brace") (/= '{') +#else +plainTextParser = PlainText <$> takeWhile1 (/= '{') +#endif + +jsonpathParser :: Parser K8sPathElement +#if MIN_VERSION_jsonpath(0,3,0) +jsonpathParser = JSONPath <$> (char '{' *> jsonPath (char '}') <* char '}') +#else +jsonpathParser = JSONPath <$> (char '{' *> jsonPath <* char '}') +#endif + +runJSONPath :: [K8sPathElement] -> Value -> Either String Text +runJSONPath [] _ = pure "" +runJSONPath (e:es) v = do + res <- runPathElement e v + rest <- runJSONPath es v + pure $ res <> rest + +runPathElement :: K8sPathElement -> Value -> Either String Text +runPathElement (PlainText t) _ = pure t +runPathElement (JSONPath p) v = encodeResult $ executeJSONPath p v + +#if MIN_VERSION_jsonpath(0,3,0) +encodeResult :: [Value] -> Either String Text +encodeResult vals = return $ (intercalate " " $ Prelude.map jsonToText vals) +#else +encodeResult :: ExecutionResult Value -> Either String Text +encodeResult (ResultValue val) = return $ jsonToText val +encodeResult (ResultList vals) = return $ (intercalate " " $ Prelude.map jsonToText vals) +encodeResult (ResultError err) = Left err +#endif + +jsonToText :: Value -> Text +jsonToText (String t) = t +jsonToText x = toStrict $ encodeToLazyText x diff --git a/test/Kubernetes/Client/Auth/BasicSpec.hs b/test/Kubernetes/Client/Auth/BasicSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kubernetes/Client/Auth/BasicSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Client.Auth.BasicSpec where + +import Test.Hspec +import Data.Typeable +import Data.Maybe ( isJust + , isNothing + , fromJust + ) +import Kubernetes.Client.Auth.Basic +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI +import Network.TLS ( defaultParamsClient ) + +emptyAuthInfo :: AuthInfo +emptyAuthInfo = AuthInfo Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +spec :: Spec +spec = do + let testTLSParams = defaultParamsClient "" "" + testUsername = Just "testuser" + testPassword = Just "testpassword" + basicAuthInfo = emptyAuthInfo { username = testUsername, password = testPassword} + describe "Basic Authentication" $ do + it "should return Nothing if the username an d/or password is not provided" $ do + testConfig <- newConfig + isNothing (basicAuth emptyAuthInfo (testTLSParams, testConfig)) + `shouldBe` True + isNothing (basicAuth emptyAuthInfo { username = testUsername} (testTLSParams, testConfig)) + `shouldBe` True + isNothing (basicAuth emptyAuthInfo { password = testUsername} (testTLSParams, testConfig)) + `shouldBe` True + + context "when username and password are provided" $ do + it "should return a configuration provider io" $ do + testConfig <- newConfig + isJust (basicAuth basicAuthInfo (testTLSParams, testConfig)) `shouldBe` True + + it "should configure basic auth" $ do + testConfig <- newConfig + (_, (KubernetesClientConfig { configAuthMethods = AnyAuthMethod (a) : as })) <- + fromJust $ basicAuth basicAuthInfo (testTLSParams, testConfig) + null as `shouldBe` True + isJust (cast a :: Maybe BasicAuth) `shouldBe` True diff --git a/test/Kubernetes/Client/Auth/ClientCertSpec.hs b/test/Kubernetes/Client/Auth/ClientCertSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kubernetes/Client/Auth/ClientCertSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Kubernetes.Client.Auth.ClientCertSpec where + +import Test.Hspec + +import Data.FileEmbed +import Data.Maybe (isJust, isNothing) +import Data.Text.Encoding (decodeUtf8) +import Kubernetes.Client.Auth.ClientCert +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI +import Network.TLS (defaultParamsClient) + +import qualified Data.ByteString.Base64 as B64 + +emptyAuthInfo :: AuthInfo +emptyAuthInfo = AuthInfo Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +spec :: Spec +spec = do + let inputTLSParams = defaultParamsClient "" "" + certFilePath = "test/testdata/certs/certificate.pem" + keyFilePath = "test/testdata/certs/private-key.pem" + base64EncodedCert = decodeUtf8 $ B64.encode $(embedFile $ "test/testdata/certs/certificate.pem") + base64EncodedKey = decodeUtf8 $ B64.encode $(embedFile $ "test/testdata/certs/private-key.pem") + describe "ClientCert File Authentication" $ do + context "when cert and key file are provided in AuthInfo" $ do + let auth = emptyAuthInfo { clientCertificate = Just $ certFilePath + , clientKey = Just $ keyFilePath } + it "should detect client cert file auth" $ do + inputConfig <- newConfig + isJust (clientCertFileAuth auth (inputTLSParams, inputConfig)) `shouldBe` True + + it "should disable validate auth method" $ do + inputConfig <- newConfig + case clientCertFileAuth auth (inputTLSParams, inputConfig) of + Nothing -> expectationFailure "expected to detect client cert file auth" + Just detectedAuth -> do + (_, cfg) <- detectedAuth + configValidateAuthMethods cfg `shouldBe` False + + it "should return Nothing if the cert file is not provided" $ do + let auth = emptyAuthInfo {clientKey = Just "/some/file"} + inputConfig <- newConfig + isNothing (clientCertFileAuth auth (inputTLSParams, inputConfig)) `shouldBe` True + + it "should return Nothing if the key file is not provided" $ do + let auth = emptyAuthInfo {clientCertificate = Just "/some/file"} + inputConfig <- newConfig + isNothing (clientCertFileAuth auth (undefined, inputConfig)) `shouldBe` True + + describe "ClientCert Data Authentication" $ do + context "when cert and key file are provided in AuthInfo" $ do + let auth = emptyAuthInfo { clientCertificateData = Just base64EncodedCert + , clientKeyData = Just base64EncodedKey} + it "should detect client cert data auth" $ do + inputConfig <- newConfig + isJust (clientCertDataAuth auth (inputTLSParams, inputConfig)) `shouldBe` True + + it "should disable validate auth method" $ do + inputConfig <- newConfig + case clientCertDataAuth auth (inputTLSParams, inputConfig) of + Nothing -> expectationFailure "expected to detect client cert file auth" + Just detectedAuth -> do + (_, cfg) <- detectedAuth + configValidateAuthMethods cfg `shouldBe` False + + it "should return Nothing if the cert file is not provided" $ do + let auth = emptyAuthInfo {clientKeyData = Just base64EncodedKey} + inputConfig <- newConfig + isNothing (clientCertDataAuth auth (inputTLSParams, inputConfig)) `shouldBe` True + + it "should return Nothing if the key file is not provided" $ do + let auth = emptyAuthInfo {clientCertificateData = Just base64EncodedCert} + inputConfig <- newConfig + isNothing (clientCertDataAuth auth (inputTLSParams, inputConfig)) `shouldBe` True diff --git a/test/Kubernetes/Client/Auth/TokenFileSpec.hs b/test/Kubernetes/Client/Auth/TokenFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kubernetes/Client/Auth/TokenFileSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +module Kubernetes.Client.Auth.TokenFileSpec where + +import Test.Hspec +import Control.Concurrent +import Data.Function ( (&) ) +import Data.FileEmbed +import Data.Typeable +import Data.Maybe ( isJust + , isNothing + ) +import Data.Text ( Text ) +import Data.Text.Encoding ( decodeUtf8 ) +import Kubernetes.Client.Auth.TokenFile +import Kubernetes.Client.KubeConfig +import Kubernetes.OpenAPI +import Kubernetes.OpenAPI.Core ( _applyAuthMethods + , _mkRequest + ) +import Network.TLS ( defaultParamsClient ) + +import qualified Data.ByteString.Base64 as B64 + +emptyAuthInfo :: AuthInfo +emptyAuthInfo = AuthInfo Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +spec :: Spec +spec = do + let testTLSParams = defaultParamsClient "" "" + token1FilePath = "test/testdata/tokens/token1" + token2FilePath = "test/testdata/tokens/token2" + describe "TokenFile Authentication" $ do + it "should return Nothing if the file is not provided" $ do + testConfig <- newConfig + isNothing (tokenFileAuth emptyAuthInfo (testTLSParams, testConfig)) + `shouldBe` True + + it "should reload token after expiry" $ do + let auth = emptyAuthInfo { tokenFile = Just token1FilePath } + testConfig <- newConfig + case tokenFileAuth auth (testTLSParams, testConfig) of + Nothing -> expectationFailure "expected to detect TokenFile auth" + Just detectedAuth -> do + (_, cfg@(KubernetesClientConfig { configAuthMethods = AnyAuthMethod (a) : as })) <- + detectedAuth + case cast a :: Maybe TokenFileAuth of + Nothing -> expectationFailure "expected to be TokenFile auth" + Just tf -> do + let tfWithShorterPeriod = tf { period = 5 } + x <- getToken tfWithShorterPeriod + x `shouldBe` ("token1" :: Text) + + let tfWithShorterPeriod' = + tfWithShorterPeriod { file = token2FilePath } + threadDelay 2000000 -- sleep 2 seconds + x <- getToken tfWithShorterPeriod' + x `shouldBe` ("token1" :: Text) + + threadDelay 3000000 -- sleep 3 seconds + x <- getToken tfWithShorterPeriod' + x `shouldBe` ("token2" :: Text) + diff --git a/test/Kubernetes/Client/KubeConfigSpec.hs b/test/Kubernetes/Client/KubeConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kubernetes/Client/KubeConfigSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Kubernetes.Client.KubeConfigSpec where + +import Data.Aeson (decode, encode, parseJSON, + toJSON) +import Data.Either (fromRight) +import Data.Yaml (decodeFileEither) +import Kubernetes.Client.KubeConfig (AuthInfo (..), Cluster (..), + Config, Context (..), + getAuthInfo, getCluster, + getContext) +import Test.Hspec + +spec :: Spec +spec = do + let getConfig :: IO Config + getConfig = fromRight (error "Couldn't decode config") <$> decodeFileEither "test/testdata/kubeconfig.yaml" + + describe "FromJSON and ToJSON instances" $ do + it "roundtrips successfully" $ do + config <- getConfig + decode (encode (toJSON config)) `shouldBe` Just config + + describe "getContext" $ do + it "returns the correct context" $ do + config <- getConfig + getContext config `shouldBe` (Right (Context "cluster-aaa" "user-aaa" Nothing)) + + describe "getCluster" $ do + it "returns the correct cluster" $ do + config <- getConfig + server <$> getCluster config `shouldBe` (Right "https://aaa.example.com") + + describe "getAuthInfo" $ do + it "returns the correct authInfo" $ do + config <- getConfig + fst <$> getAuthInfo config `shouldBe` (Right "user-aaa") diff --git a/test/Kubernetes/Data/K8sJSONPathSpec.hs b/test/Kubernetes/Data/K8sJSONPathSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kubernetes/Data/K8sJSONPathSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module Kubernetes.Data.K8sJSONPathSpec where + +import Test.Hspec + +import Kubernetes.Data.K8sJSONPath +import Data.Text +import Data.JSONPath +import Data.Aeson + +#if MIN_VERSION_jsonpath(0,3,0) +import Data.Void (Void) +import Test.Hspec.Megaparsec +import Text.Megaparsec (runParser) +import Text.Megaparsec.Error (ParseErrorBundle) + +(~>) :: Text -> Parser [K8sPathElement] -> Either (ParseErrorBundle Text Void) [K8sPathElement] +(~>) text parser = runParser parser "nothing" text +#else +import Test.Hspec.Attoparsec +#endif + + +spec :: Spec +spec = do + describe "K8sJSONPath" $ do + describe "Parsing" $ do + it "should parse plain text" $ do + ("plain" :: Text) ~> k8sJSONPath + `shouldParse` [PlainText "plain"] + + it "should parse jsonpath" $ do + ("{.foo}" :: Text) ~> k8sJSONPath + `shouldParse` [JSONPath [KeyChild "foo"]] + + it "should parse K8sJSONPath with both text and jsonpath" $ do + ("kind is {.kind}" :: Text) ~> k8sJSONPath + `shouldParse` [PlainText "kind is ", JSONPath [KeyChild "kind"]] + + describe "Running" $ do + it "should interpolate string with json values" $ do + let path = [PlainText "kind is ", JSONPath [KeyChild "kind"]] + val = (object ["kind" .= ("Pod" :: Text)]) + runJSONPath path val `shouldBe` Right "kind is Pod" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/testdata/certs/certificate.pem b/test/testdata/certs/certificate.pem new file mode 100644 --- /dev/null +++ b/test/testdata/certs/certificate.pem @@ -0,0 +1,17 @@ +-----BEGIN CERTIFICATE----- +MIICsDCCAZgCCQCyRyEmfEJy9jANBgkqhkiG9w0BAQUFADAZMRcwFQYDVQQDDA5z +ZWxmLXNpZ25lZC1jYTAgFw0xOTA3MjMyMTUwMThaGA8yMTI5MDEyNzIxNTAxOFow +GTEXMBUGA1UEAwwOc2VsZi1zaWduZWQtY2EwggEiMA0GCSqGSIb3DQEBAQUAA4IB +DwAwggEKAoIBAQDbxmgIae5FUbLu76NmsUbbo7D0Bk6cUpII/lhREQptoL4YkOo3 +MnLVQ6bkTG1hdWkN2A+eDHDJklNR6zzrCAA395lKhCZWSxq9o3AFWFMI8TWSptxL +X/fl/vDh1pH4u/nGjKC1fSf2F9nvxywIgd0PNttWG8bNMzl3gZULfg0TWKvSX6Ln +9SLA9Whsr3WMQno46JiKauB7z1+9Qc+26uEOi6kpc2mYIDTCUO5+umUEsV+seQS+ +TUe9lMQCLuZVmnWoygbCx5+eXm//iYOBSz8Z5jpEOuA6mY9FJAUU3uoGR656NImZ +IBjgVSZBIDleq2V/lmdbjHy8GpQTMtButMorAgMBAAEwDQYJKoZIhvcNAQEFBQAD +ggEBALHSlOI+Ra6QWr5V3FQS2ypkddK19RZ3TxEvCt8Brt2uNBw6Oxw/qLq17xiB +C7bJV1SA9MNqdv1grk1kVil5aUeAGLIQtVD3C1/qiCgfP+HN1Fb0QnMcxJwESRmc +TDQoYEkZp/TqgggDbmJD6S91EpXs1QiAvNA5+9L8ikOrOJQeHkzFen9PXoSqkVTl +XPwOsCIzcBnuq+agt3pkiFcHtm348y4Yjv3kOimAhzanR96DH2DtTBCmDE/cYW7j +s5aOI/MKlrZxh2gFvgqBZMjVUv8bNuDAU+8prDH4YzsDFeGKD42lDvnL+XQ69xKE +oLBoM+xTo5QwQp0ZWW3srw47BKo= +-----END CERTIFICATE----- diff --git a/test/testdata/certs/private-key.pem b/test/testdata/certs/private-key.pem new file mode 100644 --- /dev/null +++ b/test/testdata/certs/private-key.pem @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEowIBAAKCAQEA28ZoCGnuRVGy7u+jZrFG26Ow9AZOnFKSCP5YUREKbaC+GJDq +NzJy1UOm5ExtYXVpDdgPngxwyZJTUes86wgAN/eZSoQmVksavaNwBVhTCPE1kqbc +S1/35f7w4daR+Lv5xoygtX0n9hfZ78csCIHdDzbbVhvGzTM5d4GVC34NE1ir0l+i +5/UiwPVobK91jEJ6OOiYimrge89fvUHPturhDoupKXNpmCA0wlDufrplBLFfrHkE +vk1HvZTEAi7mVZp1qMoGwsefnl5v/4mDgUs/GeY6RDrgOpmPRSQFFN7qBkeuejSJ +mSAY4FUmQSA5Xqtlf5ZnW4x8vBqUEzLQbrTKKwIDAQABAoIBACG0nRHlRSCmdf3F +DNdcCtT2ltXl/bplw3XTpDHSnjnP9DeKShFrEEd616advgy7WABCiaqgl8+iPFsM +68vT70ymEYFnIQYNAK3i2fRH5nwxmhjCtHhu4HMKlWDdaoeuNJFp0d/jsPRCFi96 +6Vrop8GElUDwg53G5GJaokQf8dtsbg05Qv0C+BLMjYoXt+OCSYn0Jnzc3YLyn6pf +0Ubhb5X73+pSFcY0JindJzHo/c3k5255VOorimxSA9Kr0glYJ2MlOuWM7khZfWjJ +yJPEfa0hM/mPkR2WZ3Rif1Hb01BcrpjsNmQKFDKG+gumxL0CYzUlxOrVI5RO5+yC +wKw8FYkCgYEA/QSzpNxc+qtYj9lJL3p2sxN8cQNOhDOF3DdEZmwToPF2JQKqnDo0 +5LDugNgUuOilVFYGxmLNC9RMB+PgOT7kHgZY99cZFuUCww85j2NIbdoATXFZvUdD +O2E9o4X4RQ4+WQTZZ01sfjxMa6Y+t5HC49wvwHwdY0SMA3w6jPkBer8CgYEA3l1q +yJObFV6rorCoeJIpLPGs1lQpXb0qgENmE6tnwYQ56mIuP0mLiSvqkISWwQyEiPjZ +g9O70adOLom/0l9ssIsE1bHk/k/391rzYsvXvHM/uuIFNd7yqYApBLXq3jiNZbfq +CeoWkymez0VOWzgIQxh2UHZ+5+qRSMDgV6hq55UCgYBr00ofcs2pAcZvHyFCO4VE +UYSRwOAAFNjx/ReIMny29M/te9JrW57Y6tHpVKyYFIUIiNTATLCnXuS75A/VNYkP +hpL5o9AMYrInoGBeS+g88E96sViWAj2Tm6AiBODFxQkq9JcVn/ghX98NbT6DCnos +ktRCymHXwQmOHq3xD9jijwKBgGX3KFQ5e0/dTY8Yuugu/bqiR8MwbJeTer2+Kjyy +yK0wWO5lfxd+PgH0pWcHpal4d/3nPrb4jJOiyHMGr3NkVo7N8LWdEYicWvSOPDT9 +jDvaDUtBAWqmhVe8cRK76Ktl+1C9eRB6y0dIOo6JFVk25HL/8KEM9Tybj2txJm6L +yBnRAoGBAN3K6EhZ6eO0BorVNi8/5KaE8D0f3ZFEgUBEpVwiJLmL1hXbsiv2JyjE ++dR+reScpl8NODycnnFzBzlIijB52CZWo+cxyFSvZxz3RrJZ8XaM/fg5MgNmcwLQ +zejmoH7LuYD4z/OaPzgupJZlRUZNADOqZ8alsxSIvOHkImUAT9Q2 +-----END RSA PRIVATE KEY----- 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 diff --git a/test/testdata/tokens/token1 b/test/testdata/tokens/token1 new file mode 100644 --- /dev/null +++ b/test/testdata/tokens/token1 @@ -0,0 +1,1 @@ +token1 diff --git a/test/testdata/tokens/token2 b/test/testdata/tokens/token2 new file mode 100644 --- /dev/null +++ b/test/testdata/tokens/token2 @@ -0,0 +1,1 @@ +token2