Better variables all around!

2019-08-28 16:23:10 +01:00
parent 10ea92625b
commit 2e16c8dd1b
4 changed files with 84 additions and 81 deletions
--- a/kubernetes-client/src/Kubernetes/Client/Auth/GCP.hs
+++ b/kubernetes-client/src/Kubernetes/Client/Auth/GCP.hs
@@ -46,12 +46,12 @@ instance AuthMethod GCPAuth where

 -- |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))} (tls, kubecfg)
+gcpAuth AuthInfo{authProvider = Just(AuthProviderConfig "gcp" (Just cfg))} (tlsParams, kubecfg)
  = Just $ do
      configOrErr <- parseGCPAuthInfo cfg
      case configOrErr of
-        Left e    -> throwM e
-        Right gcp -> pure (tls, addAuthMethod kubecfg gcp)
+        Left err  -> throwM err
+        Right gcp -> pure (tlsParams, addAuthMethod kubecfg gcp)
 gcpAuth _ _ = Nothing

 data GCPAuthParsingException = GCPAuthMissingInformation String
@@ -69,8 +69,8 @@ data GCPGetTokenException = GCPCmdProducedInvalidJSON String
 instance Exception GCPGetTokenException

 getToken :: GCPAuth -> IO (Either GCPGetTokenException Text)
-getToken g@(GCPAuth{..}) = getCurrentToken g
-                           >>= maybe (fetchToken g) (return . Right)
+getToken auth@(GCPAuth{..}) = getCurrentToken auth
+                              >>= maybe (fetchToken auth) (return . Right)

 getCurrentToken :: GCPAuth -> IO (Maybe Text)
 getCurrentToken (GCPAuth{..}) = do
@@ -87,12 +87,12 @@ 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
-    Left x -> return $ Left x
  where
    parseTokenAndExpiry credsStr = do
      credsJSON <- Aeson.eitherDecode credsStr
@@ -106,35 +106,31 @@ fetchToken GCPAuth{..} = do
      return (token, expiry)

 parseGCPAuthInfo :: Map Text Text -> IO (Either GCPAuthParsingException GCPAuth)
-parseGCPAuthInfo m = do
-  gcpAccessToken <- atomically $ newTVar $ Map.lookup "access-token" m
+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 m "token-key" [JSONPath [KeyChild "token_expiry"]]
+    gcpTokenKey <- readJSONPath "token-key" [JSONPath [KeyChild "token_expiry"]]
                   & mapLeft GCPAuthInvalidTokenJSONPath
-    gcpExpiryKey <- readJSONPath m "expiry-key" [JSONPath [KeyChild "access_token"]]
+    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" m of
+      case Map.lookup "expiry" authInfo of
        Nothing         -> Right Nothing
        Just expiryText -> Just <$> parseExpiryTime expiryText
-    lookupEither key = Map.lookup key m
+    lookupEither key = Map.lookup key authInfo
                       & maybeToRight (GCPAuthMissingInformation $ Text.unpack key)
+    parseK8sJSONPath = parseOnly (k8sJSONPath <* endOfInput)
+    readJSONPath key defaultPath =
+      maybe (Right defaultPath) parseK8sJSONPath $ Map.lookup key authInfo

 parseExpiryTime :: Text -> Either String UTCTime
-parseExpiryTime s = zonedTimeToUTC <$> parseTimeRFC3339 s
-                    & maybeToRight ("failed to parse token expiry time " <> Text.unpack s)
-
-readJSONPath :: Map Text Text
-             -> Text
-             -> [K8sPathElement]
-             -> Either String [K8sPathElement]
-readJSONPath m key def = case Map.lookup key m of
-                           Nothing -> pure def
-                           Just str -> parseOnly (k8sJSONPath <* endOfInput) str
+parseExpiryTime expiryText =
+  zonedTimeToUTC <$> parseTimeRFC3339 expiryText
+  & maybeToRight ("failed to parse token expiry time " <> Text.unpack expiryText)
--- a/kubernetes-client/src/Kubernetes/Client/Auth/OIDC.hs
+++ b/kubernetes-client/src/Kubernetes/Client/Auth/OIDC.hs
@@ -66,30 +66,30 @@ instance Exception OIDCAuthParsingException

 -- TODO: Consider a token expired few seconds before actual expiry to account for time skew
 getToken :: OIDCAuth -> IO Text
-getToken o@(OIDCAuth{..}) = do
+getToken auth@(OIDCAuth{..}) = do
  now <- getPOSIXTime
  maybeIdToken <- readTVarIO idTokenTVar
  case maybeIdToken of
-    Nothing -> fetchToken o
+    Nothing -> fetchToken auth
    Just idToken -> do
      let maybeExp = decodeClaims (Text.encodeUtf8 idToken)
                   & rightToMaybe
                   & fmap snd
                   & (>>= jwtExp)
      case maybeExp of
-        Nothing -> fetchToken o
+        Nothing -> fetchToken auth
        Just (IntDate expiryDate) -> if now < expiryDate
                                     then pure idToken
-                                     else fetchToken o
+                                     else fetchToken auth

 fetchToken :: OIDCAuth -> IO Text
-fetchToken o@(OIDCAuth{..}) = do
+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 o
+      tokenEndpoint <- fetchTokenEndpoint mgr auth
      tokenURI <- parseURI strictURIParserOptions (Text.encodeUtf8 tokenEndpoint)
                  & either (throwM . OIDCURIException) pure
      let oauth = OAuth2{ oauthClientId = clientID
@@ -147,36 +147,38 @@ cachedOIDCAuth cache AuthInfo{authProvider = Just(AuthProviderConfig "oidc" (Jus
 cachedOIDCAuth _ _ _ = Nothing

 parseOIDCAuthInfo :: Map Text Text -> IO (Either OIDCAuthParsingException OIDCAuth)
-parseOIDCAuthInfo m = do
-  eitherTLSParams <- parseCA m
-  idTokenTVar <- atomically $ newTVar $ Map.lookup "id-token" m
-  refreshTokenTVar <- atomically $ newTVar $ Map.lookup "refresh-token" m
+parseOIDCAuthInfo authInfo = do
+  eitherTLSParams <- parseCA authInfo
+  idTokenTVar <- atomically $ newTVar $ Map.lookup "id-token" authInfo
+  refreshTokenTVar <- atomically $ newTVar $ Map.lookup "refresh-token" authInfo
  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 m
+    where lookupEither k = Map.lookup k authInfo
                           & maybeToRight (OIDCAuthMissingInformation $ Text.unpack k)

 parseCA :: Map Text Text -> IO (Either ParseCertException TLS.ClientParams)
-parseCA m = do
-  t <- defaultTLSClientParams
-  fromMaybe (pure $ pure t) (parseCAFile t m <|> parseCAData t m)
+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 t m = do
-  caFile <- Text.unpack <$> Map.lookup "idp-certificate-authority" m
+parseCAFile tlsParams authInfo = do
+  caFile <- Text.unpack <$> Map.lookup "idp-certificate-authority" authInfo
  Just $ do
    caText <- BS.readFile caFile
-    return $ updateClientParams t caText
+    return $ updateClientParams tlsParams caText

 parseCAData :: TLS.ClientParams -> Map Text Text -> Maybe (IO (Either ParseCertException TLS.ClientParams))
-parseCAData t m = do
-  caBase64 <- Map.lookup "idp-certificate-authority-data" m
+parseCAData tlsParams authInfo = do
+  caBase64 <- Map.lookup "idp-certificate-authority-data" authInfo
  Just $ pure $ do
    caText <- Text.encodeUtf8 caBase64
              & B64.decode
              & mapLeft Base64ParsingFailed
-    updateClientParams t caText
+    updateClientParams tlsParams caText
--- a/kubernetes-client/src/Kubernetes/Client/Config.hs
+++ b/kubernetes-client/src/Kubernetes/Client/Config.hs
@@ -69,20 +69,20 @@ kubeClient
  -> IO (NH.Manager, K.KubernetesClientConfig)
 kubeClient oidcCache (KubeConfigFile f) = do
  kubeConfigFile <- decodeFileThrow f
-  uri <- getCluster kubeConfigFile
+  masterURI <- getCluster kubeConfigFile
         & fmap server
         & either (const $ pure "localhost:8080") return
-  t <- defaultTLSClientParams
-       & fmap (tlsValidation kubeConfigFile)
-       & (>>= (addCACertData kubeConfigFile))
-       & (>>= addCACertFile kubeConfigFile (takeDirectory f))
-  c <- K.newConfig & fmap (setMasterURI uri)
-  (tlsParams, cfg) <-
+  tlsParams <- defaultTLSClientParams
+               & fmap (tlsValidation kubeConfigFile)
+               & (>>= (addCACertData kubeConfigFile))
+               & (>>= addCACertFile kubeConfigFile (takeDirectory f))
+  clientConfig <- K.newConfig & fmap (setMasterURI masterURI)
+  (tlsParamsWithAuth, clientConfigWithAuth) <-
    case getAuthInfo kubeConfigFile of
-      Left _          -> return (t,c)
-      Right (_, auth) -> applyAuthSettings oidcCache auth (t, c)
-  mgr <- newManager tlsParams
-  return (mgr, cfg)
+      Left _          -> return (tlsParams,clientConfig)
+      Right (_, auth) -> applyAuthSettings oidcCache auth (tlsParams, clientConfig)
+  mgr <- newManager tlsParamsWithAuth
+  return (mgr, clientConfigWithAuth)
 kubeClient _ (KubeConfigCluster) = Kubernetes.Client.Config.cluster

 -- |Creates 'NH.Manager' and 'K.KubernetesClientConfig' assuming it is being executed in a pod
@@ -113,37 +113,39 @@ serviceAccountDir :: FilePath
 serviceAccountDir = "/var/run/secrets/kubernetes.io/serviceaccount"

 tlsValidation :: Config -> TLS.ClientParams -> TLS.ClientParams
-tlsValidation cfg t = case getCluster cfg of
-                        Left _ -> t
-                        Right c -> case insecureSkipTLSVerify c of
-                                     Just True -> disableServerCertValidation t
-                                     _ -> t
+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 t =
+addCACertData cfg tlsParams =
  let eitherCertText = getCluster cfg
                       & (>>= (maybeToRight "cert data not provided" . certificateAuthorityData))
  in case eitherCertText of
-       Left _ -> pure t
+       Left _ -> pure tlsParams
       Right certBase64 -> do
         certText <- B64.decode (T.encodeUtf8 certBase64)
                     & either (throwM . Base64ParsingFailed) pure
-         updateClientParams t certText
+         updateClientParams tlsParams certText
           & either throwM return

 addCACertFile :: Config -> FilePath -> TLS.ClientParams -> IO TLS.ClientParams
-addCACertFile cfg dir t = do
-  let certFile = getCluster cfg
-                 >>= maybeToRight "cert file not provided" . certificateAuthority
-                 & fmap T.unpack
-                 & fmap (dir </>)
-  case certFile of
-    Left _ -> return t
-    Right f -> do
-      certText <- B.readFile f
+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 t certText
-        & (fromRight t)
+        $ updateClientParams tlsParams certText
+        & (fromRight tlsParams)

 applyAuthSettings
  :: OIDCCache
--- a/kubernetes-client/src/Kubernetes/Client/Internal/TLSUtils.hs
+++ b/kubernetes-client/src/Kubernetes/Client/Internal/TLSUtils.hs
@@ -39,8 +39,8 @@ defaultTLSClientParams = do

 -- |Parses a PEM-encoded @ByteString@ into a list of certificates.
 parsePEMCerts :: B.ByteString -> Either ParseCertException [SignedCertificate]
-parsePEMCerts b = do
-    pems <- pemParseBS b
+parsePEMCerts pemBS = do
+    pems <- pemParseBS pemBS
            & mapLeft PEMParsingFailed
    return $ rights $ map (decodeSignedCertificate . pemContent) pems

@@ -51,11 +51,8 @@ updateClientParams cp certText = parsePEMCerts certText

 -- |Use a custom CA store.
 setCAStore :: [SignedCertificate] -> TLS.ClientParams -> TLS.ClientParams
-setCAStore certs cp = cp
-    { TLS.clientShared = (TLS.clientShared cp)
-        { TLS.sharedCAStore = (makeCertificateStore certs)
-        }
-    }
+setCAStore certs tlsParams =
+  tlsParams & clientSharedL . sharedCAStoreL .~ makeCertificateStore certs

 -- |Use a client cert for authentication.
 setClientCert :: Credential -> TLS.ClientParams -> TLS.ClientParams
@@ -68,6 +65,12 @@ onServerCertificateL :: Lens' TLS.ClientParams (CertificateStore -> TLS.Validati
 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
@@ -84,8 +87,8 @@ onCertificateRequestL =

 -- |Loads certificates from a PEM-encoded file.
 loadPEMCerts :: (MonadIO m, MonadThrow m) => FilePath -> m [SignedCertificate]
-loadPEMCerts p = do
-    liftIO (B.readFile p)
+loadPEMCerts pemFile = do
+    liftIO (B.readFile pemFile)
        >>= (either throwM return)
        .   parsePEMCerts