diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 31b6797..dba0cdb 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.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 <> 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 diff --git a/Makefile b/Makefile index ff41316..8d188a2 100644 --- a/Makefile +++ b/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) diff --git a/azure-email/Azure/Email.hs b/azure-email/Azure/Email.hs new file mode 100644 index 0000000..795be82 --- /dev/null +++ b/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 diff --git a/azure-email/Azure/Types.hs b/azure-email/Azure/Types.hs new file mode 100644 index 0000000..8f01256 --- /dev/null +++ b/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{..} diff --git a/azure-email/CHANGELOG.md b/azure-email/CHANGELOG.md new file mode 100644 index 0000000..18f52d5 --- /dev/null +++ b/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. diff --git a/azure-email/LICENSE b/azure-email/LICENSE new file mode 100644 index 0000000..1f229d7 --- /dev/null +++ b/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. diff --git a/azure-email/azure-email.cabal b/azure-email/azure-email.cabal new file mode 100644 index 0000000..dccf94a --- /dev/null +++ b/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 diff --git a/cabal.project b/cabal.project index 3ac2529..910676f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,5 @@ packages: ./azure-auth + ./azure-email ./azure-key-vault ./azure-blob-storage