Use ADTs instead of Either String in OIDC Auth code

Author: akshaymankar

kubernetes-client/src/Kubernetes/Client/Auth/OIDC.hs

@@ -59,7 +59,8 @@ data OIDCGetTokenException = OIDCOAuthException (OAuth2Error OAuth2TokenRequest.
   deriving Show
 instance Exception OIDCGetTokenException
 
-data OIDCAuthParsingException = OIDCAuthParsingException String
+data OIDCAuthParsingException = OIDCAuthCAParsingFailed ParseCertException
+                              | OIDCAuthMissingInformation String
   deriving Show
 instance Exception OIDCAuthParsingException
 
@@ -119,7 +120,7 @@ oidcAuth :: DetectAuth
 oidcAuth AuthInfo{authProvider = Just(AuthProviderConfig "oidc" (Just cfg))} (tls, kubecfg)
   = Just
     $ parseOIDCAuthInfo cfg
-    >>= either (throwM . OIDCAuthParsingException) (\oidc -> pure (tls, addAuthMethod kubecfg oidc))
+    >>= 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
@@ -129,54 +130,53 @@ oidcAuth _ _ = Nothing
 -}
 cachedOIDCAuth :: OIDCCache -> DetectAuth
 cachedOIDCAuth cache AuthInfo{authProvider = Just(AuthProviderConfig "oidc" (Just cfg))} (tls, kubecfg) = Just $ do
-  m <- readTVarIO cache
-  o <- case findInCache m cfg of
-    Left e -> throwM $ OIDCAuthParsingException e
-    Right (Just o) -> return o
-    Right Nothing -> do
-      o@(OIDCAuth{..}) <- parseOIDCAuthInfo cfg
-                          >>= either (throwM . OIDCAuthParsingException) pure
-      let newCache = Map.insert (issuerURL, clientID) o m
+  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 o
-  pure (tls, addAuthMethod kubecfg o)
+      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
 
-findInCache :: Map (Text, Text) a -> Map Text Text -> Either String (Maybe a)
-findInCache cache cfg = do
-  issuerURL <- lookupEither cfg "idp-issuer-url"
-  clientID <- lookupEither cfg "client-id"
-  return $ Map.lookup (issuerURL, clientID) cache
-
-parseOIDCAuthInfo :: Map Text Text -> IO (Either String OIDCAuth)
+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
   return $ do
-    tlsParams <- eitherTLSParams
-    issuerURL <- lookupEither m "idp-issuer-url"
-    clientID <- lookupEither m "client-id"
-    clientSecret <- lookupEither m "client-secret"
+    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
+                           & maybeToRight (OIDCAuthMissingInformation $ Text.unpack k)
 
-parseCA :: Map Text Text -> IO (Either String TLS.ClientParams)
+parseCA :: Map Text Text -> IO (Either ParseCertException TLS.ClientParams)
 parseCA m = do
   t <- defaultTLSClientParams
   fromMaybe (pure $ pure t) (parseCAFile t m <|> parseCAData t m)
 
-parseCAFile :: TLS.ClientParams -> Map Text Text -> Maybe (IO (Either String TLS.ClientParams))
+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
-  return $ updateClientParams t <$> BS.readFile caFile
+  Just $ do
+    caText <- BS.readFile caFile
+    return $ updateClientParams t caText
 
-parseCAData :: TLS.ClientParams -> Map Text Text -> Maybe (IO (Either String TLS.ClientParams))
+parseCAData :: TLS.ClientParams -> Map Text Text -> Maybe (IO (Either ParseCertException TLS.ClientParams))
 parseCAData t m = do
-  caText <- Map.lookup "idp-certificate-authority-data" m
-  pure . pure
-    $ (B64.decode $ Text.encodeUtf8 caText)
-    >>= updateClientParams t
-
-lookupEither :: (Show key, Ord key) => Map key val -> key -> Either String val
-lookupEither m k = maybeToRight e $ Map.lookup k m
-                   where e = "Couldn't find key: " <> show k <> " in OIDC auth info"
+  caBase64 <- Map.lookup "idp-certificate-authority-data" m
+  Just $ pure $ do
+    caText <- Text.encodeUtf8 caBase64
+              & B64.decode
+              & mapLeft Base64ParsingFailed
+    updateClientParams t caText

kubernetes-client/src/Kubernetes/Client/Config.hs

@@ -125,10 +125,11 @@ addCACertData cfg t =
                        & (>>= (maybeToRight "cert data not provided" . certificateAuthorityData))
   in case eitherCertText of
        Left _ -> pure t
-       Right certText ->
-         (B64.decode $ T.encodeUtf8 certText)
-         >>= updateClientParams t
-         & either (throwM . ParsePEMCertsException) return
+       Right certBase64 -> do
+         certText <- B64.decode (T.encodeUtf8 certBase64)
+                     & either (throwM . Base64ParsingFailed) pure
+         updateClientParams t certText
+           & either throwM return
 
 addCACertFile :: Config -> FilePath -> TLS.ClientParams -> IO TLS.ClientParams
 addCACertFile cfg dir t = do

kubernetes-client/src/Kubernetes/Client/Internal/TLSUtils.hs

@@ -6,9 +6,9 @@ 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.Function              ((&))
 import Data.PEM                   (pemContent, pemParseBS)
-import Data.Typeable              (Typeable)
 import Data.X509                  (SignedCertificate, decodeSignedCertificate)
 import Data.X509.CertificateStore (CertificateStore, makeCertificateStore)
 import Lens.Micro
@@ -38,12 +38,14 @@ defaultTLSClientParams = do
         }
 
 -- |Parses a PEM-encoded @ByteString@ into a list of certificates.
-parsePEMCerts :: B.ByteString -> Either String [SignedCertificate]
+parsePEMCerts :: B.ByteString -> Either ParseCertException [SignedCertificate]
 parsePEMCerts b = do
     pems <- pemParseBS b
+            & mapLeft PEMParsingFailed
     return $ rights $ map (decodeSignedCertificate . pemContent) pems
 
-updateClientParams :: TLS.ClientParams -> ByteString -> Either String TLS.ClientParams
+-- | 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))
 
@@ -80,23 +82,26 @@ onCertificateRequestL :: Lens' TLS.ClientParams (([TLS.CertificateType], Maybe [
 onCertificateRequestL =
   clientHooksL . lens TLS.onCertificateRequest (\ch ocr -> ch { TLS.onCertificateRequest = ocr })
 
-data ParsePEMCertsException = ParsePEMCertsException String deriving (Typeable, Show)
-
-instance Exception ParsePEMCertsException
-
 -- |Loads certificates from a PEM-encoded file.
 loadPEMCerts :: (MonadIO m, MonadThrow m) => FilePath -> m [SignedCertificate]
 loadPEMCerts p = do
     liftIO (B.readFile p)
-        >>= throwLeft
+        >>= (either throwM return)
         .   parsePEMCerts
 
 -- |Loads Base64 encoded certificate and private key
 loadB64EncodedCert :: (MonadThrow m) => B.ByteString -> B.ByteString -> m Credential
-loadB64EncodedCert certB64 keyB64 =  throwLeft $ do
+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
 
-throwLeft :: (MonadThrow m) => Either String a -> m a
-throwLeft = either (throwM . ParsePEMCertsException) return
+instance Exception ParseCertException