diff --git a/README.md b/README.md index a563fa8..3500b0f 100644 --- a/README.md +++ b/README.md @@ -14,10 +14,10 @@ started. Covered areas: To build the entire project, run: ``` -stack build +cabal build all ``` In order to build individual components of the library, `cd` into the package and run: ``` -cabal build +cabal build -O0 ``` diff --git a/azure-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal index 89e820a..be1ee4f 100644 --- a/azure-blob-storage/azure-blob-storage.cabal +++ b/azure-blob-storage/azure-blob-storage.cabal @@ -53,10 +53,12 @@ common common-options library import: common-options exposed-modules: Azure.Blob.Types - Azure.Clients + Azure.GetBlob + Azure.PutBlob build-depends: azure-auth , bytestring , http-client-tls + , http-media , servant , servant-client , text diff --git a/azure-blob-storage/src/Azure/GetBlob.hs b/azure-blob-storage/src/Azure/GetBlob.hs new file mode 100644 index 0000000..5f4223b --- /dev/null +++ b/azure-blob-storage/src/Azure/GetBlob.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Azure.GetBlob + ( getBlobObject + , getBlobObjectEither + ) where + +import Azure.Blob.Types (AccountName (..), BlobName (..), ContainerName (..)) +import Data.ByteString (ByteString, fromStrict, toStrict) +import Data.Data (Proxy (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text (Text) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Media (MediaType) +import Servant.API +import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) +import UnliftIO (MonadIO (..), throwString) + +import Azure.Auth (defaultAzureCredential) +import qualified Azure.Types as Auth +import qualified Data.Text as Text +import GHC.Generics (Generic) +import qualified Network.HTTP.Media as M + +blobStorageResourceUrl :: Text +blobStorageResourceUrl = "https://storage.azure.com/" + +getBlobObject :: + MonadIO m => + GetBlob -> + m ByteString +getBlobObject getBlobReq = do + res <- liftIO $ getBlobObjectEither getBlobReq + case res of + Left err -> + throwString $ show err + Right r -> + pure r + +getBlobObjectEither :: + MonadIO m => + GetBlob -> + m (Either Text ByteString) +getBlobObjectEither getBlobReq = do + res <- + liftIO $ + callGetBlobClient getBlobObjectApi getBlobReq + pure $ + case res of + Right r -> Right r + Left err -> Left err + +data GetBlob = GetBlob + { accountName :: !AccountName + , containerName :: !ContainerName + , blobName :: !BlobName + , tokenStore :: !Auth.Token + } + deriving stock (Eq, Generic) + +-- | Phantom type to encapsulate the data type in servant client types +data Blob + +type GetBlobApi = + Capture "container-name" ContainerName + :> Capture "blob-name" BlobName + :> Header' '[Required, Strict] "Authorization" Text + :> Header' '[Required, Strict] "x-ms-version" Text + :> Get '[Blob] ByteString + +instance Accept Blob where + contentTypes :: Proxy Blob -> NonEmpty MediaType + contentTypes _ = + ("text" M.// "plain" M./: ("charset", "utf-8")) + :| [ "application" M.// "octet-stream" + , "text" M.// "csv" + , "application" M.// "x-dbt" + ] + +instance MimeRender Blob ByteString where + mimeRender _ = fromStrict + +instance MimeUnrender Blob ByteString where + mimeUnrender _ = Right . toStrict + +getBlobObjectApi :: ContainerName -> BlobName -> Text -> Text -> ClientM ByteString +getBlobObjectApi = client (Proxy @GetBlobApi) + +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 + manager <- liftIO newTlsManager + res <- + liftIO $ + runClientM + (action containerName blobName ("Bearer " <> atAccessToken) "2020-04-08") + (mkClientEnv manager $ BaseUrl Https mkHostUrl 443 "") + pure $ case res of + Left err -> do + Left . Text.pack $ show err + Right response -> do + Right response + where + mkHostUrl = Text.unpack (unAccountName accountName) <> ".blob.core.windows.net" diff --git a/azure-blob-storage/src/Azure/Clients.hs b/azure-blob-storage/src/Azure/PutBlob.hs similarity index 99% rename from azure-blob-storage/src/Azure/Clients.hs rename to azure-blob-storage/src/Azure/PutBlob.hs index 408e708..3069a1d 100644 --- a/azure-blob-storage/src/Azure/Clients.hs +++ b/azure-blob-storage/src/Azure/PutBlob.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Azure.Clients +module Azure.PutBlob ( putBlobObjectEither , putBlobObject ) where