Shared Access Signature

Holmusk · Aug 3, 2024 · ccbf0ad · ccbf0ad
1 parent 1064015
commit ccbf0ad
Show file tree

Hide file tree

Showing 4 changed files with 163 additions and 8 deletions.
diff --git a/azure-blob-storage/azure-blob-storage.cabal b/azure-blob-storage/azure-blob-storage.cabal
@@ -68,6 +68,7 @@ library
                     , servant-xml ^>= 1.0.3
                     , xmlbf
                     , text
+                    , time
                     , unliftio
                     , unordered-containers
     hs-source-dirs:   src

diff --git a/azure-blob-storage/src/Azure/Blob/Types.hs b/azure-blob-storage/src/Azure/Blob/Types.hs
@@ -8,6 +8,12 @@ module Azure.Blob.Types
     , BlobType (..)
     , UserDelegationRequest (..)
     , UserDelegationResponse (..)
+    , SasTokenExpiry (..)
+    , Url (..)
+    , SasPermissions (..)
+    , sasPermissionsToText
+    , SasResource (..)
+    , sasResourceToText
     ) where
 
 import Data.Aeson (ToJSON (..), object, (.=))
@@ -105,6 +111,17 @@ instance FromXml UserDelegationResponse where
         udrValue <- pElement "Value" pText
         pure UserDelegationResponse{..}
 
+-- | Newtype for an url that can be fetched directly
+newtype Url = Url
+    { unUrl :: Text
+    }
+    deriving stock (Eq, Show, Generic)
+
+-- | For an azure action to be turned into a signed url
+newtype SasTokenExpiry = SasTokenExpiry
+    { unSasTokenExpiry :: Int
+    }
+
 data SasPermissions
     = SasRead
     | SasAdd

diff --git a/azure-blob-storage/src/Azure/SharedAccessSignature.hs b/azure-blob-storage/src/Azure/SharedAccessSignature.hs
@@ -1 +1,143 @@
-module Azure.SharedAccessSignature () where
+module Azure.SharedAccessSignature
+    ( generateSas
+    ) where
+
+import Azure.Auth (defaultAzureCredential)
+import Azure.Blob.Types
+    ( AccountName (..)
+    , BlobName (..)
+    , ContainerName (..)
+    , SasPermissions (..)
+    , SasResource (..)
+    , SasTokenExpiry (..)
+    , Url (..)
+    , UserDelegationRequest (..)
+    , UserDelegationResponse (..)
+    , sasPermissionsToText
+    , sasResourceToText
+    )
+import Azure.UserDelegationKey (callGetUserDelegationKeyApi, getUserDelegationKeyApi)
+import Data.Text (Text)
+import Data.Time (UTCTime (..), addUTCTime, formatTime, getCurrentTime)
+import Data.Time.Format (defaultTimeLocale)
+import UnliftIO (MonadIO (..))
+
+import qualified Azure.Types as Auth
+import qualified Data.Text as Text
+
+blobStorageResourceUrl :: Text
+blobStorageResourceUrl = "https://storage.azure.com/"
+
+generateSas ::
+    MonadIO m =>
+    AccountName ->
+    ContainerName ->
+    BlobName ->
+    SasTokenExpiry ->
+    Auth.Token ->
+    m (Either Text Url)
+generateSas accountName containerName blobName (SasTokenExpiry expiry) tokenStore = do
+    accessToken <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore
+    now <- liftIO getCurrentTime
+    let isoStartTime = formatToAzureTime now
+        isoExpiryTime = formatToAzureTime (addUTCTime (fromIntegral expiry) now)
+    userDelgationKey <-
+        liftIO $
+            callGetUserDelegationKeyApi getUserDelegationKeyApi accountName accessToken (UserDelegationRequest isoStartTime isoExpiryTime)
+    pure $ case userDelgationKey of
+        Left err -> Left err
+        Right UserDelegationResponse{..} -> do
+            let canonicalizedResource =
+                    "/blob/"
+                        <> unAccountName accountName
+                        <> "/"
+                        <> unContainerName containerName
+                        <> "/"
+                        <> unBlobName blobName
+                -- Source: https://learn.microsoft.com/en-us/rest/api/storageservices/create-user-delegation-sas#version-2020-12-06-and-later
+                stringToSign =
+                    sasPermissionsToText SasRead -- signedPermissions
+                        <> "\n"
+                        <> isoStartTime -- signedStart
+                        <> "\n"
+                        <> isoExpiryTime -- signedExpiry
+                        <> "\n"
+                        <> canonicalizedResource -- canonicalizedResource
+                        <> "\n"
+                        <> udrSignedKeyOid -- signedKeyObjectId
+                        <> "\n"
+                        <> udrSignedKeyTid -- signedKeyTenantId
+                        <> "\n"
+                        <> udrSignedKeyStart -- signedKeyStart
+                        <> "\n"
+                        <> udrSignedKeyExpiry -- signedKeyExpiry
+                        <> "\n"
+                        <> udrSignedKeyService -- signedKeyService
+                        <> "\n"
+                        <> udrSignedKeyVersion -- signedKeyVersion
+                        <> "\n"
+                        <> "" -- signedAuthorizedUserObjectId
+                        <> "\n"
+                        <> "" -- signedUnauthorizedUserObjectId
+                        <> "\n"
+                        <> "" -- signedCorrelationId
+                        <> "\n"
+                        <> "" -- signedIP
+                        <> "\n"
+                        <> "https" -- signedProtocol
+                        <> "\n"
+                        <> "2022-11-02" -- signedVersion
+                        <> "\n"
+                        <> sasResourceToText SasBlob -- signedResource
+                        <> "\n"
+                        <> "" -- signedSnapshotTime
+                        <> "\n"
+                        <> "" -- signedEncryptionScope
+                        <> "\n"
+                        <> "" -- rscc
+                        <> "\n"
+                        <> "" -- rscd
+                        <> "\n"
+                        <> "" -- rsce
+                        <> "\n"
+                        <> "" -- rscl
+                        <> "\n"
+                        <> "" -- rsct
+            let sig = buildSignature stringToSign udrValue
+            Right
+                . Url
+                $ "https://"
+                    <> unAccountName accountName
+                    <> ".blob.core.windows.net/"
+                    <> unContainerName containerName
+                    <> "/"
+                    <> unBlobName blobName
+                    <> "?sp="
+                    <> sasPermissionsToText SasRead
+                    <> "&st="
+                    <> isoStartTime
+                    <> "&se="
+                    <> isoExpiryTime
+                    <> "&skoid="
+                    <> udrSignedKeyOid
+                    <> "&sktid="
+                    <> udrSignedKeyTid
+                    <> "&skt="
+                    <> udrSignedKeyStart
+                    <> "&ske="
+                    <> udrSignedKeyExpiry
+                    <> "&sks="
+                    <> udrSignedKeyService
+                    <> "&skv="
+                    <> udrSignedKeyVersion
+                    <> "&sv=2022-11-02"
+                    <> "&spr=https"
+                    <> "&sr="
+                    <> sasResourceToText SasBlob
+                    <> "&sig="
+                    <> decodeUtf8 (urlEncode True $ encodeUtf8 sig)
+  where
+    -- Date time formatting rules for azure:
+    -- https://learn.microsoft.com/en-us/rest/api/storageservices/formatting-datetime-values
+    formatToAzureTime :: UTCTime -> Text
+    formatToAzureTime time = Text.pack $ formatTime defaultTimeLocale "%FT%TZ" time
diff --git a/azure-blob-storage/src/Azure/UserDelegationKey.hs b/azure-blob-storage/src/Azure/UserDelegationKey.hs
@@ -9,7 +9,6 @@ module Azure.UserDelegationKey
     , getUserDelegationKeyApi
     ) where
 
-import Azure.Auth (defaultAzureCredential)
 import Azure.Blob.Types
     ( AccountName (..)
     , UserDelegationRequest (..)
@@ -26,9 +25,6 @@ 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
@@ -52,12 +48,11 @@ getUserDelegationKeyApi = client (Proxy @GetUserDelegationKeyApi)
 callGetUserDelegationKeyApi ::
     (Restype -> Comp -> Text -> Text -> UserDelegationRequest -> ClientM UserDelegationResponse) ->
     AccountName ->
-    Auth.Token ->
+    Auth.AccessToken ->
     UserDelegationRequest ->
     IO (Either Text UserDelegationResponse)
-callGetUserDelegationKeyApi action accountName tokenStore req = do
+callGetUserDelegationKeyApi action accountName Auth.AccessToken{atAccessToken} req = do
     manager <- liftIO newTlsManager
-    Auth.AccessToken{atAccessToken} <- liftIO $ defaultAzureCredential Nothing blobStorageResourceUrl tokenStore
     res <-
         liftIO $
             runClientM