Blob storage

.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