APIs for email communication

.github/workflows/haskell-ci.yml

@@ -140,6 +140,7 @@ jobs:
         run: |
           touch cabal.project
           echo "packages: $GITHUB_WORKSPACE/source/./azure-auth" >> cabal.project
+          echo "packages: $GITHUB_WORKSPACE/source/./azure-email" >> 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
@@ -155,6 +156,8 @@ jobs:
         run: |
           PKGDIR_azure_auth="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/azure-auth-[0-9.]*')"
           echo "PKGDIR_azure_auth=${PKGDIR_azure_auth}" >> "$GITHUB_ENV"
+          PKGDIR_azure_email="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/azure-email-[0-9.]*')"
+          echo "PKGDIR_azure_email=${PKGDIR_azure_email}" >> "$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.]*')"
@@ -163,17 +166,20 @@ jobs:
           touch cabal.project
           touch cabal.project.local
           echo "packages: ${PKGDIR_azure_auth}" >> cabal.project
+          echo "packages: ${PKGDIR_azure_email}" >> 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-email" >> 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-blob-storage|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-email|azure-key-vault)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan
@@ -200,6 +206,8 @@ jobs:
         run: |
           cd ${PKGDIR_azure_auth} || false
           ${CABAL} -vnormal check
+          cd ${PKGDIR_azure_email} || false
+          ${CABAL} -vnormal check
           cd ${PKGDIR_azure_key_vault} || false
           ${CABAL} -vnormal check
           cd ${PKGDIR_azure_blob_storage} || false

Makefile

@@ -1,4 +1,4 @@
-SRC=$(shell find azure-auth/ azure-key-vault/ azure-blob-storage/ -type f -name '*.hs')
+SRC=$(shell find azure-auth/ azure-key-vault/ azure-blob-storage/ azure-email/ -type f -name '*.hs')
 
 .PHONY: format
 format: $(SRC)

azure-email/Azure/Email.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Azure.Email (sendEmail, sendEmailEither) where
+
+import Azure.Types (AzureEmailRequest (..))
+import Crypto.Hash.SHA256 (hash, hmac)
+import Data.Aeson (encode)
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
+import Network.HTTP.Client.TLS (newTlsManager)
+import Servant.API
+import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM)
+import UnliftIO (MonadIO (..))
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.Text as Text
+
+sendEmail ::
+    MonadIO m =>
+    Text ->
+    m ()
+sendEmail apiSecret = undefined
+
+sendEmailEither ::
+    MonadIO m =>
+    Text ->
+    m (Either Text ())
+sendEmailEither apiSecret = undefined
+
+type SendEmailApi =
+    "emails:send"
+        :> QueryParam' '[Required, Strict] "api-version" Text
+        :> Header' '[Required, Strict] "x-ms-date" Text
+        :> Header' '[Required, Strict] "Host" Text
+        :> Header' '[Required, Strict] "x-ms-content-sha256" Text
+        :> Header' '[Required, Strict] "Authorization" Text
+        :> ReqBody '[JSON] AzureEmailRequest
+        :> PostNoContent
+
+sendEmailApi :: Text -> Text -> Text -> Text -> Text -> AzureEmailRequest -> ClientM NoContent
+sendEmailApi = client (Proxy @SendEmailApi)
+
+callSendEmailClient ::
+    (Text -> Text -> Text -> Text -> Text -> AzureEmailRequest -> ClientM NoContent) ->
+    AzureEmailRequest ->
+    Text ->
+    Text ->
+    IO (Either Text ())
+callSendEmailClient action req azureEmailHost secret = do
+    manager <- liftIO newTlsManager
+    (formatToAzureTime -> now) <- getCurrentTime
+    encodedPayload <- encodePayload
+    let stringToSign =
+            "POST\n"
+                <> "/emails:send?api-version="
+                <> apiVersion
+                <> "\n"
+                <> now
+                <> ";"
+                <> azureEmailHost
+                <> ";"
+                <> encodedPayload
+    let sign = buildSignature stringToSign secret
+    res <-
+        liftIO $
+            runClientM
+                (action apiVersion now azureEmailHost encodedPayload ("HMAC-SHA256 SignedHeaders=x-ms-date;host;x-ms-content-sha256&Signature=" <> sign) req)
+                (mkClientEnv manager $ BaseUrl Https (Text.unpack azureEmailHost) 443 "")
+    pure $ case res of
+        Left err -> do
+            Left . Text.pack $ show err
+        Right _ -> do
+            Right ()
+  where
+    apiVersion :: Text
+    apiVersion = "2023-03-31"
+
+    encodePayload :: IO Text
+    encodePayload = do
+        let contentBytes = encode req
+            hashedBytes = hash (BS.toStrict contentBytes)
+            encodedHash = B64.encode hashedBytes
+        pure $ decodeUtf8 encodedHash
+
+    -- TODO: formatToAzureTime and buildSignature are borrowed from azure-blob-storage.
+    -- We should not be duplicating these utility functions
+    formatToAzureTime :: UTCTime -> Text
+    formatToAzureTime time = Text.pack $ formatTime defaultTimeLocale "%FT%TZ" time
+
+    buildSignature :: Text -> Text -> Text
+    buildSignature stringToSign sec =
+        let decodedSecret = B64.decodeLenient (C8.pack (Text.unpack sec))
+            encodedStringToSign = C8.pack (Text.unpack stringToSign)
+            hashedBytes = hmac decodedSecret encodedStringToSign
+            encodedSignature = B64.encode hashedBytes
+         in decodeUtf8 encodedSignature

azure-email/Azure/Types.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+
+module Azure.Types (AzureEmailRequest (..), AzureEmailResponse (..)) where
+
+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.:), (.=))
+import Data.Aeson.Types (parseFail)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+data EmailAddress = EmailAddress
+    { eaEmail :: !Text
+    , eaDisplayName :: !Text
+    }
+    deriving stock (Eq, Show, Generic)
+
+instance ToJSON EmailAddress where
+    toJSON EmailAddress{..} =
+        object
+            [ "address" .= eaEmail
+            , "displayName" .= eaDisplayName
+            ]
+
+-- | Fields to represent @cc@, @bcc@ and @to@ in an email
+data EmailRecipients = EmailRecipients
+    { ccRecipients :: ![EmailAddress]
+    , bccRecipients :: ![EmailAddress]
+    , toRecipients :: ![EmailAddress]
+    }
+    deriving stock (Generic)
+
+instance ToJSON EmailRecipients where
+    toJSON EmailRecipients{..} =
+        object
+            [ "to" .= toRecipients
+            , "cc" .= ccRecipients
+            , "bcc" .= bccRecipients
+            ]
+
+-- | Azure email requires both HTML and plain text format email content
+data EmailContent = EmailContent
+    { ecHtml :: !Text
+    -- ^ Html version of the email message.
+    , ecPlainText :: !Text
+    -- ^ Plain text version of the email message.
+    , ecSubject :: !Text
+    -- ^ Subject of the email message.
+    }
+    deriving stock (Eq, Show, Generic)
+
+instance ToJSON EmailContent where
+    toJSON EmailContent{..} =
+        object
+            [ "plainText" .= ecPlainText
+            , "html" .= ecHtml
+            , "subject" .= ecSubject
+            ]
+
+data EmailAttachment = EmailAttachment
+    { eaContentInBase64 :: !Text
+    -- ^ Base64 encoded contents of the attachment
+    , eaContentType :: !Text
+    -- ^ MIME type of the attachment
+    , eaName :: !Text
+    -- ^ Name of the attachment
+    }
+    deriving stock (Generic)
+
+instance ToJSON EmailAttachment where
+    toJSON EmailAttachment{..} =
+        object
+            [ "name" .= eaName
+            , "contentType" .= eaContentType
+            , "contentInBase64" .= eaContentInBase64
+            ]
+
+{- | Source:
+https://learn.microsoft.com/en-us/rest/api/communication/dataplane/email/send?view=rest-communication-dataplane-2023-03-31&tabs=HTTP
+-}
+data AzureEmailRequest = AzureEmailRequest
+    { aerContent :: !EmailContent
+    , aerRecipients :: !EmailRecipients
+    , aerSenderAddress :: !Text -- TODO: This should probably be it's own newtype
+    , aerReplyTo :: ![EmailAddress] -- TODO: Should this be NonEmpty instead?
+    , aerAttachments :: ![EmailAttachment]
+    , aerUserEngagementTrackingDisabled :: !Bool
+    }
+    deriving stock (Generic)
+
+instance ToJSON AzureEmailRequest where
+    toJSON AzureEmailRequest{..} =
+        object
+            [ "content" .= aerContent
+            , "recipients" .= aerRecipients
+            , "senderAddress" .= aerSenderAddress
+            , "replyTo" .= aerReplyTo
+            , "attachments" .= aerAttachments
+            , "userEngagementTrackingDisabled" .= aerUserEngagementTrackingDisabled
+            ]
+
+{- | Possible states once a send email action is triggered.
+Source: https://learn.microsoft.com/en-us/rest/api/communication/dataplane/email/send?view=rest-communication-dataplane-2023-03-31&tabs=HTTP#emailsendstatus
+-}
+data EmailSendStatus
+    = Canceled
+    | Failed
+    | NotStarted
+    | Running
+    | Succeeded
+    deriving stock (Eq, Show, Generic, Enum, Bounded)
+
+instance FromJSON EmailSendStatus where
+    parseJSON = withText "EmailSendStatus" $ \case
+        "Canceled" -> pure Canceled
+        "Failed" -> pure Failed
+        "NotStarted" -> pure NotStarted
+        "Running" -> pure Running
+        "Succeeded" -> pure Succeeded
+        invalidStatus -> parseFail $ "Unexpected EmailSendStatus: " <> show invalidStatus
+
+data AzureEmailResponse = AzureEmailResponse
+    { aerId :: !Text
+    , aerStatus :: !EmailSendStatus
+    }
+    deriving stock (Eq, Show, Generic)
+
+instance FromJSON AzureEmailResponse where
+    parseJSON = withObject "AzureEmailResponse" $ \o -> do
+        aerId <- o .: "id"
+        aerStatus <- o .: "status"
+        pure AzureEmailResponse{..}

azure-email/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for azure-auth
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

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

@@ -0,0 +1,65 @@
+cabal-version:      3.0
+name:               azure-email
+version:            0.1.0.0
+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.
+license:            MIT
+author:             Holmusk
+maintainer:         tech@holmusk.com
+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.Email
+                      Azure.Types
+    build-depends:    aeson
+                    , base64-bytestring
+                    , bytestring
+                    , cryptohash-sha256
+                    , http-client-tls
+                    , servant
+                    , servant-client
+                    , time
+                    , text
+                    , unliftio
+    default-language: Haskell2010

cabal.project

@@ -1,4 +1,5 @@
 packages:
   ./azure-auth
+  ./azure-email
   ./azure-key-vault
   ./azure-blob-storage