From 87247c5d6f73557cba1e206bf15c31d7623a6d26 Mon Sep 17 00:00:00 2001 From: Nitin Prakash Date: Mon, 28 Oct 2024 18:03:55 +0530 Subject: [PATCH 1/2] Add top level APIs for fetching secrets --- azure-key-vault/Azure/Secret.hs | 76 +++++++++++++++++---------- azure-key-vault/Azure/Secret/Types.hs | 25 +++++++++ azure-key-vault/azure-key-vault.cabal | 3 +- 3 files changed, 75 insertions(+), 29 deletions(-) create mode 100644 azure-key-vault/Azure/Secret/Types.hs diff --git a/azure-key-vault/Azure/Secret.hs b/azure-key-vault/Azure/Secret.hs index 148bb0a..9aef004 100644 --- a/azure-key-vault/Azure/Secret.hs +++ b/azure-key-vault/Azure/Secret.hs @@ -1,37 +1,58 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Azure.Secret - ( KeyVaultResponse (..) - , GetSecretFromVaultApi - , getSecretFromVault - , callKeyVaultClient + ( getSecret + , getSecretEither ) where -import Data.Aeson (FromJSON (..), withObject, (.:)) import Data.Data (Proxy (..)) import Data.Text (Text) -import GHC.Generics (Generic) import Network.HTTP.Client.TLS (newTlsManager) import Servant.API (Capture, Get, Header', JSON, QueryParam', Required, Strict, (:>)) import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) -import UnliftIO (MonadIO (..), throwIO) +import UnliftIO (MonadIO (..), throwString) -import Azure.Auth (defaultAzureCredential) -import Azure.Types (AccessToken (..), Token) +import Azure.Secret.Types (KeyVaultHost (..), KeyVaultResponse (..), SecretName (..)) +import Azure.Types (AccessToken (..)) import qualified Data.Text as Text -newtype KeyVaultResponse = KeyVaultResponse - { unKeyValueReponse :: Text - } - deriving stock (Eq, Show, Generic) +{- | Fetches a secret from Key vault. -instance FromJSON KeyVaultResponse where - parseJSON = withObject "KeyVaultResponse" $ \o -> do - unKeyValueReponse <- o .: "value" - pure KeyVaultResponse{..} +All errors are thrown in IO. For variant where error is +caught in a @Left@ branch, see @getSecretEither@ +-} +getSecret :: + MonadIO m => + -- | Name of the secret + SecretName -> + -- | Host to identify the key vault. This is where all the request will be + -- made. It is of the form @{keyvault-name}.vault.azure.net@ + KeyVaultHost -> + -- | Access token which will form part of the authentication header + AccessToken -> + m KeyVaultResponse +getSecret secretName host accessToken = do + res <- getSecretEither secretName host accessToken + case res of + Left err -> throwString $ show err + Right value -> pure value + +{- | Fetches a secret from key vault provided the name of the secret and the key vault host. +These secrets can be found under @/secrets@ path under key vault section in Azure portal. +-} +getSecretEither :: + MonadIO m => + -- | Name of the secret + SecretName -> + -- | Host to identify the key vault. This is where all the request will be + -- made. It is of the form @{keyvault-name}.vault.azure.net@ + KeyVaultHost -> + -- | Access token which will form part of the authentication header + AccessToken -> + m (Either Text KeyVaultResponse) +getSecretEither = callKeyVaultClient getSecretFromVault {- Path: GET {vaultBaseUrl}/secrets/{secret-name}/{secret-version}?api-version=7.4 @@ -52,20 +73,19 @@ getSecretFromVault = client (Proxy @GetSecretFromVaultApi) callKeyVaultClient :: MonadIO m => (Text -> Float -> Text -> ClientM KeyVaultResponse) -> - Text -> - Text -> - Token -> - m KeyVaultResponse -callKeyVaultClient action secretName vaultHost tokenStore = do + SecretName -> + KeyVaultHost -> + AccessToken -> + m (Either Text KeyVaultResponse) +callKeyVaultClient action (SecretName secretName) (KeyVaultHost vaultHost) accessToken = do manager <- liftIO newTlsManager - authHeader <- defaultAzureCredential Nothing vaultHost tokenStore res <- liftIO $ runClientM - (action secretName 7.4 ("Bearer " <> atAccessToken authHeader)) + (action secretName 7.4 ("Bearer " <> atAccessToken accessToken)) (mkClientEnv manager $ BaseUrl Https (Text.unpack vaultHost) 443 "") - case res of + pure $ case res of Left err -> - throwIO err + Left . Text.pack $ show err Right response -> - pure response + Right response diff --git a/azure-key-vault/Azure/Secret/Types.hs b/azure-key-vault/Azure/Secret/Types.hs new file mode 100644 index 0000000..8c1e399 --- /dev/null +++ b/azure-key-vault/Azure/Secret/Types.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Azure.Secret.Types + ( KeyVaultResponse (..) + , SecretName (..) + , KeyVaultHost (..) + ) where + +import Data.Aeson (FromJSON (..), withObject, (.:)) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype KeyVaultResponse = KeyVaultResponse + { unKeyValueReponse :: Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON KeyVaultResponse where + parseJSON = withObject "KeyVaultResponse" $ \o -> do + unKeyValueReponse <- o .: "value" + pure KeyVaultResponse{..} + +newtype SecretName = SecretName {unSecretName :: Text} deriving stock (Eq, Show) + +newtype KeyVaultHost = KeyVaultHost {unKeyVaultHost :: Text} deriving stock (Eq, Show) diff --git a/azure-key-vault/azure-key-vault.cabal b/azure-key-vault/azure-key-vault.cabal index 5580613..c0d829a 100644 --- a/azure-key-vault/azure-key-vault.cabal +++ b/azure-key-vault/azure-key-vault.cabal @@ -52,7 +52,8 @@ common common-options library import: common-options - exposed-modules: Azure.Secret + exposed-modules: Azure.Secret.Types + Azure.Secret build-depends: aeson , azure-auth , http-client-tls From 7f75d3d926ae6201da4f0fe3fda016097436e6f7 Mon Sep 17 00:00:00 2001 From: Nitin Prakash Date: Mon, 28 Oct 2024 19:44:26 +0530 Subject: [PATCH 2/2] add example --- azure-key-vault/azure-key-vault.cabal | 10 ++++++++++ azure-key-vault/example/Main.hs | 16 ++++++++++++++++ 2 files changed, 26 insertions(+) create mode 100644 azure-key-vault/example/Main.hs diff --git a/azure-key-vault/azure-key-vault.cabal b/azure-key-vault/azure-key-vault.cabal index c0d829a..afba7ef 100644 --- a/azure-key-vault/azure-key-vault.cabal +++ b/azure-key-vault/azure-key-vault.cabal @@ -62,3 +62,13 @@ library , text , unliftio default-language: Haskell2010 + +executable example + main-is: Main.hs + hs-source-dirs: example + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base >= 4.7 && < 5 + , azure-auth + , azure-key-vault diff --git a/azure-key-vault/example/Main.hs b/azure-key-vault/example/Main.hs new file mode 100644 index 0000000..f660f49 --- /dev/null +++ b/azure-key-vault/example/Main.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Azure.Secret (getSecret) +import Azure.Secret.Types (KeyVaultHost (..), SecretName (..)) +import Azure.Types (newEmptyToken) +import Azure.Auth (defaultAzureCredential) + +main :: IO () +main = do + tok <- newEmptyToken + cred <- defaultAzureCredential Nothing "https://vault.azure.net" tok + -- In order to run this, you need to replace @SecretName@ and @KeyVaultHost@ with + -- appropriate values in your resource group. These are just dummy values. + getSecret (SecretName "radiohead") (KeyVaultHost "albums") cred >>= print