diff --git a/azure-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal index 647b525..7019c49 100644 --- a/azure-blob-storage/azure-blob-storage.cabal +++ b/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 diff --git a/azure-blob-storage/src/Azure/Blob/Types.hs b/azure-blob-storage/src/Azure/Blob/Types.hs index 34a14d9..317741c 100644 --- a/azure-blob-storage/src/Azure/Blob/Types.hs +++ b/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" diff --git a/azure-blob-storage/src/Azure/SharedAccessSignature.hs b/azure-blob-storage/src/Azure/SharedAccessSignature.hs new file mode 100644 index 0000000..a69a17b --- /dev/null +++ b/azure-blob-storage/src/Azure/SharedAccessSignature.hs @@ -0,0 +1 @@ +module Azure.SharedAccessSignature () where diff --git a/azure-blob-storage/src/Azure/UserDelegationKey.hs b/azure-blob-storage/src/Azure/UserDelegationKey.hs new file mode 100644 index 0000000..b624c1e --- /dev/null +++ b/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"