From 005afad878ca5e9ae08dda0149b4cc9d7d21e065 Mon Sep 17 00:00:00 2001 From: Nitin Prakash Date: Mon, 28 Oct 2024 20:14:49 +0530 Subject: [PATCH] Require AccessToken from top level API calls --- .../src/Azure/Blob/DeleteBlob.hs | 15 +++++----- azure-blob-storage/src/Azure/Blob/GetBlob.hs | 15 +++++----- azure-blob-storage/src/Azure/Blob/PutBlob.hs | 15 +++++----- .../src/Azure/Blob/SharedAccessSignature.hs | 30 +++++++++---------- azure-blob-storage/src/Azure/Blob/Types.hs | 8 +++++ .../src/Azure/Blob/UserDelegationKey.hs | 19 ++++++------ azure-key-vault/example/Main.hs | 2 +- 7 files changed, 54 insertions(+), 50 deletions(-) diff --git a/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs b/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs index 7525347..af3f05f 100644 --- a/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs +++ b/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs @@ -11,9 +11,6 @@ module Azure.Blob.DeleteBlob , DeleteBlob (..) ) where -import Azure.Auth (defaultAzureCredential) -import Azure.Blob.Types (AccountName (..), BlobName (..), ContainerName (..)) -import Azure.Blob.Utils (blobStorageResourceUrl, mkBlobHostUrl) import Data.Data (Proxy (..)) import Data.Text (Text) import GHC.Generics (Generic) @@ -22,14 +19,17 @@ import Servant.API import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) import UnliftIO (MonadIO (..), throwString) -import qualified Azure.Types as Auth +import Azure.Blob.Types (AccountName (..), BlobName (..), ContainerName (..)) +import Azure.Blob.Utils (mkBlobHostUrl) +import Azure.Types (AccessToken (..)) + import qualified Data.Text as Text data DeleteBlob = DeleteBlob { accountName :: !AccountName , containerName :: !ContainerName , blobName :: !BlobName - , tokenStore :: !Auth.Token + , accessToken :: !AccessToken } deriving stock (Eq, Generic) @@ -72,13 +72,12 @@ callDeleteBlobClient :: (ContainerName -> BlobName -> Text -> Text -> ClientM NoContent) -> DeleteBlob -> IO (Either Text ()) -callDeleteBlobClient action DeleteBlob{accountName, containerName, blobName, tokenStore} = do - Auth.AccessToken{atAccessToken} <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore +callDeleteBlobClient action DeleteBlob{accountName, containerName, blobName, accessToken} = do manager <- liftIO newTlsManager res <- liftIO $ runClientM - (action containerName blobName ("Bearer " <> atAccessToken) "2020-04-08") + (action containerName blobName ("Bearer " <> atAccessToken accessToken) "2020-04-08") (mkClientEnv manager $ BaseUrl Https (mkBlobHostUrl accountName) 443 "") pure $ case res of Left err -> do diff --git a/azure-blob-storage/src/Azure/Blob/GetBlob.hs b/azure-blob-storage/src/Azure/Blob/GetBlob.hs index 1710b81..d7179cd 100644 --- a/azure-blob-storage/src/Azure/Blob/GetBlob.hs +++ b/azure-blob-storage/src/Azure/Blob/GetBlob.hs @@ -12,9 +12,6 @@ module Azure.Blob.GetBlob , GetBlob (..) ) where -import Azure.Auth (defaultAzureCredential) -import Azure.Blob.Types (AccountName (..), BlobName (..), ContainerName (..)) -import Azure.Blob.Utils (blobStorageResourceUrl, mkBlobHostUrl) import Data.ByteString (ByteString, fromStrict, toStrict) import Data.Data (Proxy (..)) import Data.List.NonEmpty (NonEmpty ((:|))) @@ -26,7 +23,10 @@ import Servant.API import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) import UnliftIO (MonadIO (..), throwString) -import qualified Azure.Types as Auth +import Azure.Blob.Types (AccountName (..), BlobName (..), ContainerName (..)) +import Azure.Blob.Utils (mkBlobHostUrl) +import Azure.Types (AccessToken (..)) + import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text import qualified Network.HTTP.Media as M @@ -35,7 +35,7 @@ data GetBlob = GetBlob { accountName :: !AccountName , containerName :: !ContainerName , blobName :: !BlobName - , tokenStore :: !Auth.Token + , accessToken :: !AccessToken } deriving stock (Eq, Generic) @@ -104,13 +104,12 @@ callGetBlobClient :: (ContainerName -> BlobName -> Text -> Text -> ClientM ByteString) -> GetBlob -> IO (Either Text ByteString) -callGetBlobClient action GetBlob{accountName, containerName, blobName, tokenStore} = do - Auth.AccessToken{atAccessToken} <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore +callGetBlobClient action GetBlob{accountName, containerName, blobName, accessToken} = do manager <- liftIO newTlsManager res <- liftIO $ runClientM - (action containerName blobName ("Bearer " <> atAccessToken) "2020-04-08") + (action containerName blobName ("Bearer " <> atAccessToken accessToken) "2020-04-08") (mkClientEnv manager $ BaseUrl Https (mkBlobHostUrl accountName) 443 "") pure $ case res of Left err -> do diff --git a/azure-blob-storage/src/Azure/Blob/PutBlob.hs b/azure-blob-storage/src/Azure/Blob/PutBlob.hs index 12792eb..bc50c6a 100644 --- a/azure-blob-storage/src/Azure/Blob/PutBlob.hs +++ b/azure-blob-storage/src/Azure/Blob/PutBlob.hs @@ -10,9 +10,6 @@ module Azure.Blob.PutBlob , PutBlob (..) ) where -import Azure.Auth (defaultAzureCredential) -import Azure.Blob.Types (AccountName (..), BlobName (..), BlobType (..), ContainerName (..)) -import Azure.Blob.Utils (blobStorageResourceUrl, mkBlobHostUrl) import Data.ByteString (ByteString) import Data.Data (Proxy (..)) import Data.Text (Text) @@ -22,7 +19,10 @@ import Servant.API import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) import UnliftIO (MonadIO (..), throwString) -import qualified Azure.Types as Auth +import Azure.Blob.Types (AccountName (..), BlobName (..), BlobType (..), ContainerName (..), blobTypeToText) +import Azure.Blob.Utils (mkBlobHostUrl) +import Azure.Types (AccessToken (..)) + import qualified Data.Text as Text {- | Adds a blob to a container. @@ -33,7 +33,7 @@ data PutBlob = PutBlob { accountName :: !AccountName , containerName :: !ContainerName , blobName :: !BlobName - , tokenStore :: !Auth.Token + , accessToken :: !AccessToken , body :: !ByteString -- TODO: Add chunked upload } deriving stock (Eq, Generic) @@ -86,13 +86,12 @@ callPutBlobClient :: (ContainerName -> BlobName -> Text -> Text -> Text -> ByteString -> ClientM NoContent) -> PutBlob -> IO (Either Text ()) -callPutBlobClient action PutBlob{accountName, containerName, blobName, tokenStore, body} = do - Auth.AccessToken{atAccessToken} <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore +callPutBlobClient action PutBlob{..} = do manager <- liftIO newTlsManager res <- liftIO $ runClientM - (action containerName blobName ("Bearer " <> atAccessToken) "2020-04-08" (Text.pack $ show BlockBlob) body) + (action containerName blobName ("Bearer " <> atAccessToken accessToken) "2020-04-08" (blobTypeToText BlockBlob) body) (mkClientEnv manager $ BaseUrl Https (mkBlobHostUrl accountName) 443 "") pure $ case res of Left err -> diff --git a/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs b/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs index 929fd39..d3ab069 100644 --- a/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs +++ b/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs @@ -6,7 +6,14 @@ module Azure.Blob.SharedAccessSignature , generateSasEither ) where -import Azure.Auth (defaultAzureCredential) +import Crypto.Hash.SHA256 (hmac) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (UTCTime (..), addUTCTime, formatTime, getCurrentTime) +import Data.Time.Format (defaultTimeLocale) +import Network.HTTP.Types.URI (urlEncode) +import UnliftIO (MonadIO (..), throwString) + import Azure.Blob.Types ( AccountName (..) , BlobName (..) @@ -21,16 +28,8 @@ import Azure.Blob.Types , sasResourceToText ) import Azure.Blob.UserDelegationKey (callGetUserDelegationKeyApi, getUserDelegationKeyApi) -import Azure.Blob.Utils (blobStorageResourceUrl) -import Crypto.Hash.SHA256 (hmac) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time (UTCTime (..), addUTCTime, formatTime, getCurrentTime) -import Data.Time.Format (defaultTimeLocale) -import Network.HTTP.Types.URI (urlEncode) -import UnliftIO (MonadIO (..), throwString) +import Azure.Types (AccessToken (..)) -import qualified Azure.Types as Auth import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C8 import qualified Data.Text as Text @@ -41,10 +40,10 @@ generateSas :: ContainerName -> BlobName -> SasTokenExpiry -> - Auth.Token -> + AccessToken -> m Url -generateSas accountName containerName blobName expiry tokenStore = do - eUrl <- liftIO $ generateSasEither accountName containerName blobName expiry tokenStore +generateSas accountName containerName blobName expiry accessToken = do + eUrl <- liftIO $ generateSasEither accountName containerName blobName expiry accessToken case eUrl of Left err -> throwString $ show err @@ -58,10 +57,9 @@ generateSasEither :: ContainerName -> BlobName -> SasTokenExpiry -> - Auth.Token -> + AccessToken -> m (Either Text Url) -generateSasEither accountName containerName blobName (SasTokenExpiry expiry) tokenStore = do - accessToken <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore +generateSasEither accountName containerName blobName (SasTokenExpiry expiry) accessToken = do now <- liftIO getCurrentTime let isoStartTime = formatToAzureTime now isoExpiryTime = formatToAzureTime (addUTCTime (fromIntegral expiry) now) diff --git a/azure-blob-storage/src/Azure/Blob/Types.hs b/azure-blob-storage/src/Azure/Blob/Types.hs index c1f8d06..6034586 100644 --- a/azure-blob-storage/src/Azure/Blob/Types.hs +++ b/azure-blob-storage/src/Azure/Blob/Types.hs @@ -13,6 +13,7 @@ module Azure.Blob.Types , sasPermissionsToText , SasResource (..) , sasResourceToText + , blobTypeToText ) where import Data.Aeson (ToJSON (..), object, (.=)) @@ -47,6 +48,13 @@ data BlobType | AppendBlob deriving stock (Eq, Show, Generic) +blobTypeToText :: BlobType -> Text +blobTypeToText = \case + BlockBlob -> "BlockBlob" + PageBlob -> "PageBlob" + AppendBlob -> "AppendBlob" +{-# INLINE blobTypeToText #-} + {- | The fields are supposed to be ISO format strings TODO: make these UTCTime formats -} diff --git a/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs b/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs index 1df48d0..6107011 100644 --- a/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs +++ b/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs @@ -9,12 +9,6 @@ module Azure.Blob.UserDelegationKey , getUserDelegationKeyApi ) where -import Azure.Blob.Types - ( AccountName (..) - , UserDelegationRequest (..) - , UserDelegationResponse (..) - ) -import Azure.Blob.Utils (mkBlobHostUrl) import Data.Data (Proxy (..)) import Data.Text (Text) import Network.HTTP.Client.TLS (newTlsManager) @@ -23,7 +17,14 @@ import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, import Servant.XML (XML) import UnliftIO (MonadIO (..)) -import qualified Azure.Types as Auth +import Azure.Blob.Types + ( AccountName (..) + , UserDelegationRequest (..) + , UserDelegationResponse (..) + ) +import Azure.Blob.Utils (mkBlobHostUrl) +import Azure.Types (AccessToken (..)) + import qualified Data.Text as Text -- These type aliases always hold static values. @@ -49,10 +50,10 @@ getUserDelegationKeyApi = client (Proxy @GetUserDelegationKeyApi) callGetUserDelegationKeyApi :: (Restype -> Comp -> Text -> Text -> UserDelegationRequest -> ClientM UserDelegationResponse) -> AccountName -> - Auth.AccessToken -> + AccessToken -> UserDelegationRequest -> IO (Either Text UserDelegationResponse) -callGetUserDelegationKeyApi action accountName Auth.AccessToken{atAccessToken} req = do +callGetUserDelegationKeyApi action accountName AccessToken{atAccessToken} req = do manager <- liftIO newTlsManager res <- liftIO $ diff --git a/azure-key-vault/example/Main.hs b/azure-key-vault/example/Main.hs index f660f49..5dd791e 100644 --- a/azure-key-vault/example/Main.hs +++ b/azure-key-vault/example/Main.hs @@ -2,10 +2,10 @@ module Main where +import Azure.Auth (defaultAzureCredential) import Azure.Secret (getSecret) import Azure.Secret.Types (KeyVaultHost (..), SecretName (..)) import Azure.Types (newEmptyToken) -import Azure.Auth (defaultAzureCredential) main :: IO () main = do