User delegation API

azure-blob-storage/azure-blob-storage.cabal

@@ -56,13 +56,19 @@ library
                       Azure.GetBlob
                       Azure.DeleteBlob
                       Azure.PutBlob
+                      Azure.UserDelegationKey
+                      Azure.SharedAccessSignature
     build-depends:    azure-auth
+                    , aeson
                     , bytestring
                     , http-client-tls
                     , http-media
                     , servant
                     , servant-client
+                    , servant-xml ^>= 1.0.3
+                    , xmlbf
                     , text
                     , unliftio
+                    , unordered-containers
     hs-source-dirs:   src
     default-language: Haskell2010

azure-blob-storage/src/Azure/Blob/Types.hs

@@ -6,12 +6,18 @@ module Azure.Blob.Types
     , AccountName (..)
     , PutBlob (..)
     , BlobType (..)
+    , UserDelegationRequest (..)
+    , UserDelegationResponse (..)
     ) where
 
+import Data.Aeson (ToJSON (..), object, (.=))
 import Data.ByteString (ByteString)
 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
 
 import qualified Azure.Types as Auth
 
@@ -51,3 +57,84 @@ data PutBlob = PutBlob
     , body :: !ByteString -- TODO: Add chunked upload
     }
     deriving stock (Eq, 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{..}
+
+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"

azure-blob-storage/src/Azure/SharedAccessSignature.hs

@@ -0,0 +1 @@
+module Azure.SharedAccessSignature () where

azure-blob-storage/src/Azure/UserDelegationKey.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Azure.UserDelegationKey
+    ( callGetUserDelegationKeyApi
+    , getUserDelegationKeyApi
+    ) where
+
+import Azure.Auth (defaultAzureCredential)
+import Azure.Blob.Types
+    ( AccountName (..)
+    , UserDelegationRequest (..)
+    , UserDelegationResponse (..)
+    )
+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
+
+blobStorageResourceUrl :: Text
+blobStorageResourceUrl = "https://storage.azure.com/"
+
+-- 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.Token ->
+    UserDelegationRequest ->
+    IO (Either Text UserDelegationResponse)
+callGetUserDelegationKeyApi action accountName tokenStore req = do
+    manager <- liftIO newTlsManager
+    Auth.AccessToken{atAccessToken} <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore
+    res <-
+        liftIO $
+            runClientM
+                (action showResType showComp ("Bearer " <> atAccessToken) "2022-11-02" req)
+                (mkClientEnv manager $ BaseUrl Https mkHostUrl 443 "")
+    pure $ case res of
+        -- TODO: this should actually log the error
+        Left err ->
+            Left . Text.pack $ show err
+        Right resp ->
+            Right resp
+  where
+    showComp = "userdelegationkey"
+    showResType = "service"
+    mkHostUrl = Text.unpack (unAccountName accountName) <> ".blob.core.windows.net"