diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 4af49e3..31b6797 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -48,11 +48,6 @@ jobs: compilerVersion: 9.2.8 setup-method: ghcup allow-failure: false - - compiler: ghc-9.0.2 - compilerKind: ghc - compilerVersion: 9.0.2 - setup-method: ghcup - allow-failure: false fail-fast: false steps: - name: apt @@ -146,6 +141,7 @@ jobs: touch cabal.project echo "packages: $GITHUB_WORKSPACE/source/./azure-auth" >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/./azure-key-vault" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/./azure-blob-storage" >> cabal.project cat cabal.project - name: sdist run: | @@ -161,18 +157,23 @@ jobs: echo "PKGDIR_azure_auth=${PKGDIR_azure_auth}" >> "$GITHUB_ENV" PKGDIR_azure_key_vault="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/azure-key-vault-[0-9.]*')" echo "PKGDIR_azure_key_vault=${PKGDIR_azure_key_vault}" >> "$GITHUB_ENV" + PKGDIR_azure_blob_storage="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/azure-blob-storage-[0-9.]*')" + echo "PKGDIR_azure_blob_storage=${PKGDIR_azure_blob_storage}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local echo "packages: ${PKGDIR_azure_auth}" >> cabal.project echo "packages: ${PKGDIR_azure_key_vault}" >> cabal.project + echo "packages: ${PKGDIR_azure_blob_storage}" >> cabal.project echo "package azure-auth" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package azure-key-vault" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project + echo "package azure-blob-storage" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(azure-auth|azure-blob-storage|azure-key-vault)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -195,15 +196,14 @@ jobs: - name: build run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always - - name: tests - run: | - $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - name: cabal check run: | cd ${PKGDIR_azure_auth} || false ${CABAL} -vnormal check cd ${PKGDIR_azure_key_vault} || false ${CABAL} -vnormal check + cd ${PKGDIR_azure_blob_storage} || false + ${CABAL} -vnormal check - name: haddock run: | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ff41316 --- /dev/null +++ b/Makefile @@ -0,0 +1,6 @@ +SRC=$(shell find azure-auth/ azure-key-vault/ azure-blob-storage/ -type f -name '*.hs') + +.PHONY: format +format: $(SRC) + # we use fourmolu v16 + fourmolu --mode inplace $^ 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-auth/Azure/Auth.hs b/azure-auth/Azure/Auth.hs index 3dda1e6..935bd19 100644 --- a/azure-auth/Azure/Auth.hs +++ b/azure-auth/Azure/Auth.hs @@ -10,24 +10,23 @@ module Azure.Auth , withManagedIdentityEither ) where -import Control.Monad.IO.Class (MonadIO) +import Control.Exception (Exception) import Data.Data (Proxy (..)) import Data.Text (Text) +import Data.Typeable (Typeable) import Network.HTTP.Client (defaultManagerSettings, newManager) import Servant.API (Get, Header', JSON, Optional, QueryParam', Required, Strict, (:>)) import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) import UnliftIO (MonadIO (..), throwIO) import UnliftIO.Environment (lookupEnv) -import Data.Typeable (Typeable) -import Control.Exception (Exception) -import Azure.Utils (isExpired) import Azure.Types (AccessToken (..), Token, readToken, updateToken) +import Azure.Utils (isExpired) import qualified Data.Text as Text {- | IMDS is a REST API that's available at a well-known, non-routable IP address ( 169.254. 169.254 ). -It is a local-only link can only be accessed from within the VM. +It is a local-only link can only be accessed from within the VM. Communication between the VM and IMDS never leaves the host. -} imdsHost :: String @@ -50,7 +49,6 @@ TODO: Implement other auth flows such as @withAzureCli@ and @withEnvironment@ an 1. EnvironmentCredential 2. Managed Identity (Only this is implemented at the moment) 3. Azure CLI - -} defaultAzureCredential :: MonadIO m => @@ -63,10 +61,11 @@ defaultAzureCredential :: m AccessToken defaultAzureCredential = withManagedIdentity --- | Fetches an Access token for autheticating different azure services --- All errors are thrown in IO. --- --- For version where errors are returned in a @Left@ branch, use @withManagedIdentityEither@ +{- | Fetches an Access token for autheticating different azure services +All errors are thrown in IO. + +For version where errors are returned in a @Left@ branch, use @withManagedIdentityEither@ +-} withManagedIdentity :: MonadIO m => -- | ClientId @@ -113,8 +112,11 @@ withManagedIdentityEither clientId resourceUri tokenStore = do -- In case there is no existing token, we fetch a new one Nothing -> do newToken <- callAzureIMDSEndpoint getAzureIMDSClient resourceUri clientId (Text.pack <$> identityHeader) - updateToken tokenStore (Just newToken) - pure $ Right newToken + case newToken of + Left err -> pure . Left . TokenClientMismatch . Text.pack $ show err + Right tok -> do + updateToken tokenStore (Just tok) + pure $ Right tok Just oldToken@AccessToken{atExpiresOn} -> do -- we do have a token but we should check for it's validity isTokenExpired <- isExpired atExpiresOn @@ -122,13 +124,17 @@ withManagedIdentityEither clientId resourceUri tokenStore = do then do -- get a new token and write to the env newToken <- callAzureIMDSEndpoint getAzureIMDSClient resourceUri clientId (Text.pack <$> identityHeader) - updateToken tokenStore (Just newToken) - pure $ Right newToken + case newToken of + Left err -> pure . Left . TokenClientMismatch . Text.pack $ show err + Right tok -> do + updateToken tokenStore (Just tok) + pure $ Right tok else pure $ Right oldToken -- | An exception that can occur when generating an @AccessToken@ data AccessTokenException = TokenEndpointNotAvailable Text + | TokenClientMismatch Text -- TODO: The type is misleading. This is a generic error from servant client deriving stock (Show, Typeable) instance Exception AccessTokenException @@ -160,7 +166,7 @@ callAzureIMDSEndpoint :: Text -> Maybe Text -> Maybe Text -> - m AccessToken + m (Either Text AccessToken) callAzureIMDSEndpoint action resourceUri clientId identityHeader = do manager <- liftIO $ newManager defaultManagerSettings res <- @@ -168,8 +174,8 @@ callAzureIMDSEndpoint action resourceUri clientId identityHeader = do runClientM (action imdsApiVersion resourceUri clientId identityHeader True) (mkClientEnv manager $ BaseUrl Http imdsHost 80 "") - case res of + pure $ case res of Left err -> - throwIO err + Left . Text.pack $ show err Right response -> - pure response + Right response diff --git a/azure-auth/Azure/Utils.hs b/azure-auth/Azure/Utils.hs index 3747719..978b969 100644 --- a/azure-auth/Azure/Utils.hs +++ b/azure-auth/Azure/Utils.hs @@ -6,8 +6,8 @@ import UnliftIO (MonadIO (..)) import Azure.Types (ExpiresOn) -import qualified Text.Read as Text import qualified Data.Text as Text +import qualified Text.Read as Text {- | Check if an azure access token expiration time is past or < 20 seconds from current time diff --git a/azure-auth/azure-auth.cabal b/azure-auth/azure-auth.cabal index fefc1f2..a3ddf5d 100644 --- a/azure-auth/azure-auth.cabal +++ b/azure-auth/azure-auth.cabal @@ -10,8 +10,7 @@ maintainer: tech@holmusk.com category: Azure build-type: Simple extra-doc-files: CHANGELOG.md -tested-with: GHC == 9.0.2 - GHC == 9.2.8 +tested-with: GHC == 9.2.8 GHC == 9.4.8 GHC == 9.6.3 GHC == 9.8.2 diff --git a/azure-blob-storage/CHANGELOG.md b/azure-blob-storage/CHANGELOG.md new file mode 100644 index 0000000..94fa3bc --- /dev/null +++ b/azure-blob-storage/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for azure-blob-storage + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/azure-blob-storage/LICENSE b/azure-blob-storage/LICENSE new file mode 100644 index 0000000..1f229d7 --- /dev/null +++ b/azure-blob-storage/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2024 Holmusk + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/azure-blob-storage/app/Main.hs b/azure-blob-storage/app/Main.hs new file mode 100644 index 0000000..4a4d28e --- /dev/null +++ b/azure-blob-storage/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified Blob (someFunc) + +main :: IO () +main = do + putStrLn "Hello, Haskell!" + Blob.someFunc diff --git a/azure-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal new file mode 100644 index 0000000..c9c64c7 --- /dev/null +++ b/azure-blob-storage/azure-blob-storage.cabal @@ -0,0 +1,78 @@ +cabal-version: 3.0 +name: azure-blob-storage +version: 0.1.0.0 +license: MIT +license-file: LICENSE +synopsis: Boilerplace/startkit for azure in Haskell (using servant) +description: This provides from useful functionalities for starting out with Azure in Haskell. + This includes authentication, Key vault, Blob storage and email communication related APIs. +author: Holmusk +maintainer: tech@holmusk.com +category: Azure +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC == 9.2.8 + GHC == 9.4.8 + GHC == 9.6.3 + GHC == 9.8.2 + +common common-options + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + -Wunrecognised-pragmas + -Wmissing-deriving-strategies + -Wunticked-promoted-constructors + -Winvalid-haddock + -Woperator-whitespace + -Wredundant-bang-patterns + -Wunused-packages + build-depends: base >= 4.7 && <5 + default-language: GHC2021 + default-extensions: DataKinds + DerivingStrategies + DerivingVia + LambdaCase + NoImportQualifiedPost + NoGeneralisedNewtypeDeriving + OverloadedStrings + OverloadedLabels + RecordWildCards + TypeFamilies + ViewPatterns + if os(linux) + ghc-options: -optl-fuse-ld=gold + ld-options: -fuse-ld=gold + +library + import: common-options + exposed-modules: Azure.Blob.DeleteBlob + Azure.Blob.GetBlob + Azure.Blob.PutBlob + Azure.Blob.Types + Azure.Blob.SharedAccessSignature + Azure.Blob.UserDelegationKey + Azure.Blob.Utils + build-depends: azure-auth + , aeson + , base64-bytestring + , bytestring + , cryptohash-sha256 + , http-client-tls + , http-media + , http-types + , servant + , servant-client + , servant-xml ^>= 1.0.3 + , xmlbf + , text + , time + , unliftio + , unordered-containers + hs-source-dirs: src + default-language: Haskell2010 diff --git a/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs b/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs new file mode 100644 index 0000000..7525347 --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/DeleteBlob.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Azure.Blob.DeleteBlob + ( deleteBlobObject + , deleteBlobObjectEither + , 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) +import Network.HTTP.Client.TLS (newTlsManager) +import Servant.API +import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) +import UnliftIO (MonadIO (..), throwString) + +import qualified Azure.Types as Auth +import qualified Data.Text as Text + +data DeleteBlob = DeleteBlob + { accountName :: !AccountName + , containerName :: !ContainerName + , blobName :: !BlobName + , tokenStore :: !Auth.Token + } + deriving stock (Eq, Generic) + +deleteBlobObject :: + MonadIO m => + DeleteBlob -> + m () +deleteBlobObject getBlobReq = do + res <- liftIO $ deleteBlobObjectEither getBlobReq + case res of + Left err -> + throwString $ show err + Right _ -> + pure () + +deleteBlobObjectEither :: + MonadIO m => + DeleteBlob -> + m (Either Text ()) +deleteBlobObjectEither getBlobReq = do + res <- + liftIO $ + callDeleteBlobClient deleteBlobObjectApi getBlobReq + pure $ + case res of + Right _ -> Right () + Left err -> Left err + +type DeleteBlobApi = + Capture "container-name" ContainerName + :> Capture "blob-name" BlobName + :> Header' '[Required, Strict] "Authorization" Text + :> Header' '[Required, Strict] "x-ms-version" Text + :> DeleteNoContent + +deleteBlobObjectApi :: ContainerName -> BlobName -> Text -> Text -> ClientM NoContent +deleteBlobObjectApi = client (Proxy @DeleteBlobApi) + +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 + manager <- liftIO newTlsManager + res <- + liftIO $ + runClientM + (action containerName blobName ("Bearer " <> atAccessToken) "2020-04-08") + (mkClientEnv manager $ BaseUrl Https (mkBlobHostUrl accountName) 443 "") + pure $ case res of + Left err -> do + Left . Text.pack $ show err + Right _ -> do + pure () diff --git a/azure-blob-storage/src/Azure/Blob/GetBlob.hs b/azure-blob-storage/src/Azure/Blob/GetBlob.hs new file mode 100644 index 0000000..1710b81 --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/GetBlob.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Azure.Blob.GetBlob + ( getBlobObject + , getBlobObjectEither + , 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 ((:|))) +import Data.Text (Text) +import GHC.Generics (Generic) +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 qualified Azure.Types as Auth +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +import qualified Network.HTTP.Media as M + +data GetBlob = GetBlob + { accountName :: !AccountName + , containerName :: !ContainerName + , blobName :: !BlobName + , tokenStore :: !Auth.Token + } + deriving stock (Eq, Generic) + +getBlobObject :: + MonadIO m => + GetBlob -> + FilePath -> + m () +getBlobObject getBlobReq fp = do + res <- liftIO $ getBlobObjectEither getBlobReq fp + case res of + Left err -> + throwString $ show err + Right r -> + pure r + +getBlobObjectEither :: + MonadIO m => + GetBlob -> + FilePath -> + m (Either Text ()) +getBlobObjectEither getBlobReq fp = do + res <- + liftIO $ + callGetBlobClient getBlobObjectApi getBlobReq + case res of + Right bs -> do + liftIO $ LBS.writeFile fp (fromStrict bs) + pure $ Right () + Left err -> pure $ Left err + +-- | 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 + +-- TODO: this is more of a test at the moment. +-- GET endpoint should accept any blob that is available and not just +-- rely on certain mime types +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" + , "image" M.// "jpeg" + , "image" M.// "png" + ] + +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 (mkBlobHostUrl accountName) 443 "") + pure $ case res of + Left err -> do + Left . Text.pack $ show err + Right response -> do + Right response diff --git a/azure-blob-storage/src/Azure/Blob/PutBlob.hs b/azure-blob-storage/src/Azure/Blob/PutBlob.hs new file mode 100644 index 0000000..12792eb --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/PutBlob.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Azure.Blob.PutBlob + ( putBlobObjectEither + , putBlobObject + , 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) +import GHC.Generics (Generic) +import Network.HTTP.Client.TLS (newTlsManager) +import Servant.API +import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) +import UnliftIO (MonadIO (..), throwString) + +import qualified Azure.Types as Auth +import qualified Data.Text as Text + +{- | Adds a blob to a container. + +You should have appropriate (Write) permissions in order to perform this operation. +-} +data PutBlob = PutBlob + { accountName :: !AccountName + , containerName :: !ContainerName + , blobName :: !BlobName + , tokenStore :: !Auth.Token + , body :: !ByteString -- TODO: Add chunked upload + } + deriving stock (Eq, Generic) + +{- | Upload a blob to a blob container. + +Errors will be thrown in IO. For variant where error is +caught in a @Left@ branch, see @putBlobObjectEither@ +-} +putBlobObject :: + MonadIO m => + PutBlob -> + m () +putBlobObject putBlobReq = do + res <- liftIO $ putBlobObjectEither putBlobReq + case res of + Left err -> + throwString $ show err + Right _ -> + pure () + +-- | Upload a blob to a Blob container +putBlobObjectEither :: + MonadIO m => + PutBlob -> + m (Either Text ()) +putBlobObjectEither putBlobreq = do + res <- + liftIO $ + callPutBlobClient putBlobObjectApi putBlobreq + pure $ + case res of + Right _ -> Right () + Left err -> Left err + +-- | The following method works for all @BlobType@ +type PutBlobApi = + Capture "container-name" ContainerName + :> Capture "blob-name" BlobName + :> Header' '[Required, Strict] "Authorization" Text + :> Header' '[Required, Strict] "x-ms-version" Text + :> Header' '[Required, Strict] "x-ms-blob-type" Text + :> ReqBody '[OctetStream] ByteString + :> PutNoContent + +putBlobObjectApi :: ContainerName -> BlobName -> Text -> Text -> Text -> ByteString -> ClientM NoContent +putBlobObjectApi = client (Proxy @PutBlobApi) + +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 + manager <- liftIO newTlsManager + res <- + liftIO $ + runClientM + (action containerName blobName ("Bearer " <> atAccessToken) "2020-04-08" (Text.pack $ show BlockBlob) body) + (mkClientEnv manager $ BaseUrl Https (mkBlobHostUrl accountName) 443 "") + pure $ case res of + Left err -> + Left . Text.pack $ show err + Right _ -> + Right () diff --git a/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs b/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs new file mode 100644 index 0000000..929fd39 --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/SharedAccessSignature.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Azure.Blob.SharedAccessSignature + ( generateSas + , generateSasEither + ) where + +import Azure.Auth (defaultAzureCredential) +import Azure.Blob.Types + ( AccountName (..) + , BlobName (..) + , ContainerName (..) + , SasPermissions (..) + , SasResource (..) + , SasTokenExpiry (..) + , Url (..) + , UserDelegationRequest (..) + , UserDelegationResponse (..) + , sasPermissionsToText + , 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 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 + +generateSas :: + MonadIO m => + AccountName -> + ContainerName -> + BlobName -> + SasTokenExpiry -> + Auth.Token -> + m Url +generateSas accountName containerName blobName expiry tokenStore = do + eUrl <- liftIO $ generateSasEither accountName containerName blobName expiry tokenStore + case eUrl of + Left err -> + throwString $ show err + Right url -> + pure url + +-- TODO: We need to add support for empty fields here. Eg: signedAuthorizedUserObjectId +generateSasEither :: + MonadIO m => + AccountName -> + ContainerName -> + BlobName -> + SasTokenExpiry -> + Auth.Token -> + m (Either Text Url) +generateSasEither accountName containerName blobName (SasTokenExpiry expiry) tokenStore = do + accessToken <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore + now <- liftIO getCurrentTime + let isoStartTime = formatToAzureTime now + isoExpiryTime = formatToAzureTime (addUTCTime (fromIntegral expiry) now) + userDelgationKey <- + liftIO $ + callGetUserDelegationKeyApi getUserDelegationKeyApi accountName accessToken (UserDelegationRequest isoStartTime isoExpiryTime) + pure $ case userDelgationKey of + Left err -> Left err + Right UserDelegationResponse{..} -> do + let canonicalizedResource = + "/blob/" + <> unAccountName accountName + <> "/" + <> unContainerName containerName + <> "/" + <> unBlobName blobName + -- Source: https://learn.microsoft.com/en-us/rest/api/storageservices/create-user-delegation-sas#version-2020-12-06-and-later + stringToSign = + sasPermissionsToText SasRead -- signedPermissions + <> "\n" + <> isoStartTime -- signedStart + <> "\n" + <> isoExpiryTime -- signedExpiry + <> "\n" + <> canonicalizedResource -- canonicalizedResource + <> "\n" + <> udrSignedKeyOid -- signedKeyObjectId + <> "\n" + <> udrSignedKeyTid -- signedKeyTenantId + <> "\n" + <> udrSignedKeyStart -- signedKeyStart + <> "\n" + <> udrSignedKeyExpiry -- signedKeyExpiry + <> "\n" + <> udrSignedKeyService -- signedKeyService + <> "\n" + <> udrSignedKeyVersion -- signedKeyVersion + <> "\n" + <> "" -- signedAuthorizedUserObjectId + <> "\n" + <> "" -- signedUnauthorizedUserObjectId + <> "\n" + <> "" -- signedCorrelationId + <> "\n" + <> "" -- signedIP + <> "\n" + <> "https" -- signedProtocol + <> "\n" + <> "2022-11-02" -- signedVersion + <> "\n" + <> sasResourceToText SasBlob -- signedResource + <> "\n" + <> "" -- signedSnapshotTime + <> "\n" + <> "" -- signedEncryptionScope + <> "\n" + <> "" -- rscc + <> "\n" + <> "" -- rscd + <> "\n" + <> "" -- rsce + <> "\n" + <> "" -- rscl + <> "\n" + <> "" -- rsct + let sig = buildSignature stringToSign udrValue + Right + . Url + $ "https://" + <> unAccountName accountName + <> ".blob.core.windows.net/" + <> unContainerName containerName + <> "/" + <> unBlobName blobName + <> "?sp=" + <> sasPermissionsToText SasRead + <> "&st=" + <> isoStartTime + <> "&se=" + <> isoExpiryTime + <> "&skoid=" + <> udrSignedKeyOid + <> "&sktid=" + <> udrSignedKeyTid + <> "&skt=" + <> udrSignedKeyStart + <> "&ske=" + <> udrSignedKeyExpiry + <> "&sks=" + <> udrSignedKeyService + <> "&skv=" + <> udrSignedKeyVersion + <> "&sv=2022-11-02" + <> "&spr=https" + <> "&sr=" + <> sasResourceToText SasBlob + <> "&sig=" + <> decodeUtf8 (urlEncode True $ encodeUtf8 sig) + where + -- Date time formatting rules for azure: + -- https://learn.microsoft.com/en-us/rest/api/storageservices/formatting-datetime-values + formatToAzureTime :: UTCTime -> Text + formatToAzureTime time = Text.pack $ formatTime defaultTimeLocale "%FT%TZ" time + + buildSignature :: Text -> Text -> Text + buildSignature stringToSign secret = + let decodedSecret = B64.decodeLenient (C8.pack (Text.unpack secret)) + encodedStringToSign = C8.pack (Text.unpack stringToSign) + hashedBytes = hmac decodedSecret encodedStringToSign + encodedSignature = B64.encode hashedBytes + in decodeUtf8 encodedSignature diff --git a/azure-blob-storage/src/Azure/Blob/Types.hs b/azure-blob-storage/src/Azure/Blob/Types.hs new file mode 100644 index 0000000..c1f8d06 --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/Types.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Azure.Blob.Types + ( BlobName (..) + , ContainerName (..) + , AccountName (..) + , BlobType (..) + , UserDelegationRequest (..) + , UserDelegationResponse (..) + , SasTokenExpiry (..) + , Url (..) + , SasPermissions (..) + , sasPermissionsToText + , SasResource (..) + , sasResourceToText + ) where + +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.API (ToHttpApiData) +import Xmlbf (FromXml (..), ToXml (..), element, pElement, pText, text) + +import qualified Data.HashMap.Strict as HashMap + +newtype AccountName = AccountName + { unAccountName :: Text + } + deriving stock (Eq, Show, Generic) + deriving (ToHttpApiData) via Text + +newtype ContainerName = ContainerName + { unContainerName :: Text + } + deriving stock (Eq, Show, Generic) + deriving (ToHttpApiData) via Text + +newtype BlobName = BlobName + { unBlobName :: Text + } + deriving stock (Eq, Show, Generic) + deriving (ToHttpApiData) via Text + +data BlobType + = BlockBlob + | PageBlob + | AppendBlob + deriving stock (Eq, Show, Generic) + +{- | The fields are supposed to be ISO format strings +TODO: make these UTCTime formats +-} +data UserDelegationRequest = UserDelegationRequest + { udrStartTime :: Text + , udrExpiryTime :: Text + } + deriving stock (Eq, Show, Generic) + +instance ToJSON UserDelegationRequest where + toJSON UserDelegationRequest{..} = + object + [ "Start" .= udrStartTime + , "Expiry" .= udrExpiryTime + ] + +instance ToXml UserDelegationRequest where + toXml UserDelegationRequest{..} = + element "KeyInfo" HashMap.empty $ + element "Start" HashMap.empty (text udrStartTime) + <> element "Expiry" HashMap.empty (text udrExpiryTime) + +data UserDelegationResponse = UserDelegationResponse + { udrSignedKeyOid :: Text + , udrSignedKeyStart :: Text + , udrSignedKeyExpiry :: Text + , udrSignedKeyService :: Text + , udrSignedKeyVersion :: Text + , udrSignedKeyTid :: Text + -- ^ This the tenantID in which the service principle is defined + , udrValue :: Text + -- ^ User delegation key. + -- Note that this cannot be used to grant access to blob resource directly. + } + deriving stock (Eq, Show, Generic) + +instance FromXml UserDelegationResponse where + fromXml = pElement "UserDelegationKey" $ do + udrSignedKeyOid <- pElement "SignedOid" pText + udrSignedKeyTid <- pElement "SignedTid" pText + udrSignedKeyStart <- pElement "SignedStart" pText + udrSignedKeyExpiry <- pElement "SignedExpiry" pText + udrSignedKeyService <- pElement "SignedService" pText + udrSignedKeyVersion <- pElement "SignedVersion" pText + udrValue <- pElement "Value" pText + pure UserDelegationResponse{..} + +-- | Newtype for an url that can be fetched directly +newtype Url = Url + { unUrl :: Text + } + deriving stock (Eq, Show, Generic) + +-- | For an azure action to be turned into a signed url +newtype SasTokenExpiry = SasTokenExpiry + { unSasTokenExpiry :: Int + } + +data SasPermissions + = SasRead + | SasAdd + | SasCreate + deriving stock (Eq, Show, Generic, Enum, Bounded) + +{-# INLINE sasPermissionsToText #-} + +-- | Reference: https://learn.microsoft.com/en-us/rest/api/storageservices/create-user-delegation-sas#specify-permissions +sasPermissionsToText :: SasPermissions -> Text +sasPermissionsToText = \case + SasRead -> "r" + SasAdd -> "a" + SasCreate -> "c" + +data SasResource + = SasBlob + | SasBlobVersion + | SasBlobSnapshot + | SasContainer + | SasDirectory + deriving stock (Eq, Show, Generic, Enum, Bounded) + +{-# INLINE sasResourceToText #-} + +-- | Reference: https://learn.microsoft.com/en-us/rest/api/storageservices/create-user-delegation-sas#specify-the-signed-resource-field +sasResourceToText :: SasResource -> Text +sasResourceToText = \case + SasBlob -> "b" + SasBlobVersion -> "bv" + SasBlobSnapshot -> "bs" + SasContainer -> "c" + SasDirectory -> "d" diff --git a/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs b/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs new file mode 100644 index 0000000..1df48d0 --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/UserDelegationKey.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Azure.Blob.UserDelegationKey + ( callGetUserDelegationKeyApi + , 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) +import Servant.API +import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) +import Servant.XML (XML) +import UnliftIO (MonadIO (..)) + +import qualified Azure.Types as Auth +import qualified Data.Text as Text + +-- These type aliases always hold static values. +-- Refer to azure docs: https://learn.microsoft.com/en-us/rest/api/storageservices/get-user-delegation-key#request +-- for the request URI syntax +type Comp = Text +type Restype = Text + +-- Client for generating user delegation key. +-- This is used to generate SAS tokens for pre-signed URLs +-- in conjuntion with azure managed identity. +type GetUserDelegationKeyApi = + QueryParam' '[Required, Strict] "restype" Restype + :> QueryParam' '[Required, Strict] "comp" Comp + :> Header' '[Required, Strict] "Authorization" Text + :> Header' '[Required, Strict] "x-ms-version" Text + :> ReqBody '[XML] UserDelegationRequest + :> Post '[XML] UserDelegationResponse + +getUserDelegationKeyApi :: Restype -> Comp -> Text -> Text -> UserDelegationRequest -> ClientM UserDelegationResponse +getUserDelegationKeyApi = client (Proxy @GetUserDelegationKeyApi) + +callGetUserDelegationKeyApi :: + (Restype -> Comp -> Text -> Text -> UserDelegationRequest -> ClientM UserDelegationResponse) -> + AccountName -> + Auth.AccessToken -> + UserDelegationRequest -> + IO (Either Text UserDelegationResponse) +callGetUserDelegationKeyApi action accountName Auth.AccessToken{atAccessToken} req = do + manager <- liftIO newTlsManager + res <- + liftIO $ + runClientM + (action showResType showComp ("Bearer " <> atAccessToken) "2022-11-02" req) + (mkClientEnv manager $ BaseUrl Https (mkBlobHostUrl accountName) 443 "") + pure $ case res of + Left err -> + Left . Text.pack $ show err + Right resp -> + Right resp + where + showComp = "userdelegationkey" + showResType = "service" diff --git a/azure-blob-storage/src/Azure/Blob/Utils.hs b/azure-blob-storage/src/Azure/Blob/Utils.hs new file mode 100644 index 0000000..06ca0b9 --- /dev/null +++ b/azure-blob-storage/src/Azure/Blob/Utils.hs @@ -0,0 +1,15 @@ +module Azure.Blob.Utils + ( blobStorageResourceUrl + , mkBlobHostUrl + ) where + +import Azure.Blob.Types (AccountName (..)) +import Data.Text (Text) + +import qualified Data.Text as Text + +blobStorageResourceUrl :: Text +blobStorageResourceUrl = "https://storage.azure.com/" + +mkBlobHostUrl :: AccountName -> String +mkBlobHostUrl (AccountName accountName) = Text.unpack accountName <> ".blob.core.windows.net" diff --git a/azure-key-vault/Azure/Secret.hs b/azure-key-vault/Azure/Secret.hs index 76266fe..148bb0a 100644 --- a/azure-key-vault/Azure/Secret.hs +++ b/azure-key-vault/Azure/Secret.hs @@ -12,11 +12,11 @@ module Azure.Secret import Data.Aeson (FromJSON (..), withObject, (.:)) import Data.Data (Proxy (..)) import Data.Text (Text) +import GHC.Generics (Generic) import Network.HTTP.Client.TLS (newTlsManager) import Servant.API (Capture, Get, Header', JSON, QueryParam', Required, Strict, (:>)) import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) import UnliftIO (MonadIO (..), throwIO) -import GHC.Generics (Generic) import Azure.Auth (defaultAzureCredential) import Azure.Types (AccessToken (..), Token) diff --git a/azure-key-vault/azure-key-vault.cabal b/azure-key-vault/azure-key-vault.cabal index 01fd1f1..5580613 100644 --- a/azure-key-vault/azure-key-vault.cabal +++ b/azure-key-vault/azure-key-vault.cabal @@ -11,8 +11,7 @@ maintainer: tech@holmusk.com category: Azure build-type: Simple extra-doc-files: CHANGELOG.md -tested-with: GHC == 9.0.2 - GHC == 9.2.8 +tested-with: GHC == 9.2.8 GHC == 9.4.8 GHC == 9.6.3 GHC == 9.8.2 diff --git a/cabal.haskell-ci b/cabal.haskell-ci new file mode 100644 index 0000000..20c4040 --- /dev/null +++ b/cabal.haskell-ci @@ -0,0 +1 @@ +distribution: jammy diff --git a/cabal.project b/cabal.project index 0008caf..3ac2529 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,4 @@ packages: ./azure-auth ./azure-key-vault + ./azure-blob-storage diff --git a/fourmolu.yaml b/fourmolu.yaml index dfccfe9..6a913d0 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -10,7 +10,23 @@ import-export-style: leading let-style: auto in-style: right-align fixities: - - infixl 5 .= # both in tomland (fixyty 5) and aeson (fixity 8) + - infixr 9 . + - infixl 8 .:, .:?, .= + - infixr 8 ?~, .~, ^? + - infixr 6 <> + - infixl 5 .= + - infixr 5 ++ + - infixl 4 <$>, <$, $>, <*>, <*, *>, <**>, <<$>>, <&> + - infix 4 ==, /= + - infixr 4 :> + - infixl 3 <|> + - infixr 3 && + - infixl 2 :> + - infixr 2 || + - infixl 1 &, >>, >>=, :- + - infix 1 =? + - infixr 1 =<<, >=>, <=< + - infixr 0 $, $! unicode: never column-limit: none # Disclaimer: enabling column-limit breaks idempotence in a few cases. function-arrows: trailing