Blob storage API + format codebase

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 $^

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,22 +112,29 @@ 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
                     if isTokenExpired
                         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,16 +166,16 @@ callAzureIMDSEndpoint ::
     Text ->
     Maybe Text ->
     Maybe Text ->
-    m AccessToken
+    m (Either Text AccessToken)
 callAzureIMDSEndpoint action resourceUri clientId identityHeader = do
     manager <- liftIO $ newManager defaultManagerSettings
     res <-
         liftIO $
             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

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

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

azure-blob-storage/src/Azure/Types.hs → 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)

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"

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)

cabal.project

@@ -1,3 +1,4 @@
 packages:
   ./azure-auth
   ./azure-key-vault
+  ./azure-blob-storage

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