Require AccessToken from top level API calls (#10)

Holmusk · Oct 28, 2024 · 21b78f4 · 21b78f4
1 parent d0ad75d
commit 21b78f4
Show file tree

Hide file tree

Showing 9 changed files with 114 additions and 52 deletions.
diff --git a/azure-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal
@@ -76,3 +76,14 @@ library
                     , unordered-containers
     hs-source-dirs:   src
     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
+    , directory
+    , azure-auth
+    , azure-blob-storage
diff --git a/azure-blob-storage/example/Main.hs b/azure-blob-storage/example/Main.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import System.Directory (doesFileExist)
+
+import Azure.Auth (defaultAzureCredential)
+import Azure.Blob.GetBlob (GetBlob (..), getBlobObject)
+import Azure.Blob.Types (AccountName (..), BlobName (..), ContainerName (..))
+import Azure.Types (newEmptyToken)
+
+main :: IO ()
+main = do
+    tok <- newEmptyToken
+    cred <- defaultAzureCredential Nothing "https://storage.azure.com" tok
+    -- In order to run this, you need to replace @AccountName@, @ContainerName@ and @BlobName@
+    -- with appropriate values in your resource group. These are just dummy values.
+    let account = AccountName "OneRepublic"
+        container = ContainerName "Native"
+        blob = BlobName "counting_stars.jpeg"
+        getBlobPayload = GetBlob account container blob cred
+    getBlobObject getBlobPayload "/tmp/counting_stars.jpeg"
+    doesFileExist "/tmp/counting_stars.jpeg" >>= print
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,10 +35,15 @@ data GetBlob = GetBlob
     { accountName :: !AccountName
     , containerName :: !ContainerName
     , blobName :: !BlobName
-    , tokenStore :: !Auth.Token
+    , accessToken :: !AccessToken
     }
     deriving stock (Eq, Generic)
 
+{- | Fetch a blob from blob storage
+
+Errors will be thrown in IO. For variant where error is
+caught in a @Left@ branch, see @getBlobObjectEither@
+-}
 getBlobObject ::
     MonadIO m =>
     GetBlob ->
@@ -52,6 +57,7 @@ getBlobObject getBlobReq fp = do
         Right r ->
             pure r
 
+-- | Fetch a blob from blob storage
 getBlobObjectEither ::
     MonadIO m =>
     GetBlob ->
@@ -104,13 +110,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,47 +28,56 @@ 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
 
+{- | Generates a Shared Access Token.
+
+Errors will be thrown in IO. For variant where error is
+caught in a @Left@ branch, see @generateSasEither@
+-}
 generateSas ::
     MonadIO m =>
+    -- | Name of the Blob storage account
     AccountName ->
+    -- | Name of the Blob container
     ContainerName ->
+    -- | Name of the blob itself
     BlobName ->
+    -- | Time in seconds for which the Shared Access Token should be valid for
     SasTokenExpiry ->
-    Auth.Token ->
+    -- | Access Token for making requests
+    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
         Right url ->
             pure url
 
--- TODO: We need to add support for empty fields here. Eg: signedAuthorizedUserObjectId
+{- | Generates a Shared Access Token.
+
+TODO: We need to add support for empty fields here. Eg: signedAuthorizedUserObjectId
+-}
 generateSasEither ::
     MonadIO m =>
+    -- | Name of the Blob storage account
     AccountName ->
+    -- | Name of the Blob container
     ContainerName ->
+    -- | Name of the blob itself
     BlobName ->
+    -- | Time in seconds for which the Shared Access Token should be valid for
     SasTokenExpiry ->
-    Auth.Token ->
+    -- | Access Token for making requests
+    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
 -}
@@ -100,7 +108,7 @@ newtype Url = Url
     }
     deriving stock (Eq, Show, Generic)
 
--- | For an azure action to be turned into a signed url
+-- | Represents how long a SAS token should be valid for in seconds.
 newtype SasTokenExpiry = SasTokenExpiry
     { unSasTokenExpiry :: Int
     }

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