Require AccessToken from top level API calls

Holmusk · Oct 28, 2024 · 005afad · 005afad
1 parent d0ad75d
commit 005afad
Show file tree

Hide file tree

Showing 7 changed files with 54 additions and 50 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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