Merge pull request #5 from Holmusk/nitin/blob-storage

Changes include:
- APIs for uploading (PUT), fetching (GET) and deleting (DELETE) blobs.
  GET method for blob service does not support streaming retrievals at the moment.
  PUT method for blob service also does not support chunked uploads at the moment.
- API for generating user delegation Shared Access Signagture (SAS).
- Drop GHC 9.0.2 from CI
- Specify linux distribution for CI

.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 <<EOF
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(azure-auth|azure-key-vault)$/; }' >> 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

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

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
 ```

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-auth/azure-auth.cabal

@@ -10,8 +10,7 @@ maintainer:         [email protected]
 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

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.

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.

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

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:         [email protected]
+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