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/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-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal index eccb338..89e820a 100644 --- a/azure-blob-storage/azure-blob-storage.cabal +++ b/azure-blob-storage/azure-blob-storage.cabal @@ -52,29 +52,14 @@ common common-options library import: common-options - exposed-modules: Azure.Types - build-depends: aeson - , azure-auth + exposed-modules: Azure.Blob.Types + Azure.Clients + build-depends: azure-auth , bytestring - , http-client , http-client-tls - , http-types , servant , servant-client , text - , time , unliftio hs-source-dirs: src default-language: Haskell2010 - -test-suite azure-blob-storage-test - import: common-options - default-language: Haskell2010 - -- other-modules: - -- other-extensions: - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - build-depends: - base ^>=4.7 && <5, - azure-blob-storage diff --git a/azure-blob-storage/src/Azure/Types.hs b/azure-blob-storage/src/Azure/Blob/Types.hs similarity index 51% rename from azure-blob-storage/src/Azure/Types.hs rename to azure-blob-storage/src/Azure/Blob/Types.hs index 2834527..34a14d9 100644 --- a/azure-blob-storage/src/Azure/Types.hs +++ b/azure-blob-storage/src/Azure/Blob/Types.hs @@ -1,19 +1,20 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} --- Introduce blob storage functions that run in IO -module Azure.Types +module Azure.Blob.Types ( BlobName (..) , ContainerName (..) , AccountName (..) + , PutBlob (..) + , BlobType (..) ) where -import Data.ByteString.Lazy (ByteString) +import Data.ByteString (ByteString) import Data.Text (Text) import GHC.Generics (Generic) import Servant.API (ToHttpApiData) +import qualified Azure.Types as Auth + newtype AccountName = AccountName { unAccountName :: Text } @@ -31,3 +32,22 @@ newtype BlobName = BlobName } deriving stock (Eq, Show, Generic) deriving (ToHttpApiData) via Text + +data BlobType + = BlockBlob + | PageBlob + | AppendBlob + deriving stock (Eq, Show, Generic) + +{- | 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) diff --git a/azure-blob-storage/src/Azure/Clients.hs b/azure-blob-storage/src/Azure/Clients.hs new file mode 100644 index 0000000..408e708 --- /dev/null +++ b/azure-blob-storage/src/Azure/Clients.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Azure.Clients + ( putBlobObjectEither + , putBlobObject + ) where + +import Azure.Auth (defaultAzureCredential) +import Azure.Blob.Types (AccountName (..), BlobName (..), BlobType (..), ContainerName (..), PutBlob (..)) +import Data.ByteString (ByteString) +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 UnliftIO (MonadIO (..), throwString) + +import qualified Azure.Types as Auth +import qualified Data.Text as Text + +blobStorageResourceUrl :: Text +blobStorageResourceUrl = "https://storage.azure.com/" + +{- | 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 mkHostUrl 443 "") + pure $ case res of + Left err -> + Left . Text.pack $ show err + Right _ -> + Right () + where + mkHostUrl = Text.unpack (unAccountName accountName) <> ".blob.core.windows.net" diff --git a/azure-blob-storage/test/Main.hs b/azure-blob-storage/test/Main.hs deleted file mode 100644 index 3e2059e..0000000 --- a/azure-blob-storage/test/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main (main) where - -main :: IO () -main = putStrLn "Test suite not yet implemented." 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/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