diff --git a/azure-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal index c9c64c7..ebb2608 100644 --- 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 new file mode 100644 index 0000000..ea2bc84 --- /dev/null +++ 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 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..8653aad 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,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 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..645727e 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,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 index c1f8d06..cd64387 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 -} @@ -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 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