azure-email (empty) → 0.1.0.0
raw patch · 4 files changed
+229/−0 lines, 4 filesdep +RSAdep +aesondep +basesetup-changed
Dependencies added: RSA, aeson, base, base64-bytestring, bytestring, cryptonite, exceptions, http-client, http-client-tls, lens-aeson, microlens, text, time, uuid, wreq
Files
- CHANGELOG.md +5/−0
- Setup.hs +2/−0
- azure-email.cabal +46/−0
- src/Azure/Email.hs +176/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for azure-email++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ azure-email.cabal view
@@ -0,0 +1,46 @@+cabal-version: 2.2+name:+ azure-email+version:+ 0.1.0.0+synopsis:+ send email with microsoft azure+--description:+homepage:+ https://github.com/layer-3-communications/azure-email+license:+ BSD-3-Clause+author:+ layer-3-communications+maintainer:+ dcartwright@layer3com.com+copyright:+ 2018 (c) Layer 3 Communications, LLC.+category:+ Web+build-type:+ Simple+extra-source-files:+ CHANGELOG.md++library+ exposed-modules:+ Azure.Email+ build-depends:+ base >=4.7 && <4.13+ , RSA+ , aeson+ , base64-bytestring+ , bytestring+ , cryptonite+ , exceptions+ , http-client+ , http-client-tls+ , lens-aeson+ , microlens+ , text+ , time+ , uuid+ , wreq+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Azure/Email.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wall #-}++module Azure.Email+ ( sendEmail+ , sendHtmlEmail+ , fetchAzureToken+ , Email(..)+ , AzureToken(..)+ , AzureCreds(..)+ ) where++import Codec.Crypto.RSA.Pure (PrivateKey)+import Control.Monad.Catch (MonadThrow, Exception, throwM)+import Data.Aeson ((.=),object)+import Data.Aeson.Lens (_String,key)+import Data.Function ((&))+import Data.Functor (void)+import Data.Monoid((<>))+import Data.Text (Text)+import Data.Time (UTCTime, addUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.UUID (UUID)+import Lens.Micro ((^?),(.~))+import Network.HTTP.Client (Manager)+import Network.Wreq+import qualified Codec.Crypto.RSA.Pure as RSA+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Base64.Lazy as Base64+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import qualified Data.UUID as UUID+import qualified Data.UUID.V4 as UUID4++data Email = Email+ { recipientAddress :: !Text+ , senderAddress :: !Text+ , subject :: !Text+ , body :: !Text+ }++sendEmailInternal ::+ IsHtml + -> Manager -- ^ HTTP manager+ -> AzureToken -- ^ token+ -> Email+ -> IO ()+sendEmailInternal isHtml mngr token (Email recipientEmail senderEmail subject' textBody) =+ void $ postWith opts+ (Text.unpack (Text.concat ["https://outlook.office365.com/api/v1.0/users/", senderEmail, "/sendmail"]))+ body'+ where+ opts = defaults+ & manager .~ Right mngr+ & header "Authorization" .~ [TextEncoding.encodeUtf8 $ "Bearer " <> getAzureToken token]+ body' = object+ [ "Message" .= object+ [ "Subject" .= subject'+ , "Body" .= object+ [ "Content" .= textBody+ , "ContentType" .= isHtmlToContentType isHtml+ ]+ , "ToRecipients" .=+ [ object+ [ "EmailAddress" .= object+ [ "Address" .= recipientEmail+ ]+ ]+ ]+ ]+ , "SaveToSentItems" .= True+ ]++sendEmail ::+ Manager+ -> AzureToken+ -> Email + -> IO ()+sendEmail = sendEmailInternal IsNotHtml++sendHtmlEmail ::+ Manager+ -> AzureToken+ -> Email+ -> IO ()+sendHtmlEmail = sendEmailInternal IsHtml+++data IsHtml = IsHtml | IsNotHtml++isHtmlToContentType :: IsHtml -> Text+isHtmlToContentType = \case { IsHtml -> "HTML"; IsNotHtml -> "Text" }++asInt :: Int -> Int; asInt = id+asText :: Text -> Text; asText = id++buildAssertion :: PrivateKey -> Text -> UUID -> UUID -> UUID -> UTCTime -> Text+buildAssertion privateKey base64Fingerprint clientId tenantId requestId now =+ TextEncoding.decodeUtf8 $ BL.toStrict $ mempty+ <> encodedHeaderAndPayload+ <> "."+ <> Base64.encode ( fromRightErr "buildAssertion: RSA signing failed"+ $ RSA.sign privateKey encodedHeaderAndPayload+ )+ where+ encodedHeaderAndPayload = mempty+ <> Base64.encode (Aeson.encode theHeader)+ <> "."+ <> Base64.encode (Aeson.encode payload)+ theHeader = object+ [ "alg" .= asText "RS256"+ , "x5t" .= base64Fingerprint+ ]+ payload = object+ [ "aud" .= Text.concat ["https://login.microsoftonline.com/", uuidToText tenantId, "/oauth2/token"]+ , "sub" .= uuidToText clientId+ , "iss" .= uuidToText clientId+ , "jti" .= uuidToText requestId+ , "nbf" .= asInt (round $ utcTimeToPOSIXSeconds now)+ , "exp" .= asInt (round $ utcTimeToPOSIXSeconds $ addUTCTime 180 now)+ ]+ +uuidToText :: UUID -> Text+uuidToText = TextEncoding.decodeUtf8 . UUID.toASCIIBytes++fetchAzureToken :: Manager -> AzureCreds -> IO AzureToken+fetchAzureToken mngr creds@(AzureCreds clientId tenantId fingerPrint privateKey) = do+ let opts = defaults & manager .~ Right mngr+ now <- getCurrentTime+ requestId <- UUID4.nextRandom+ r <- postWith opts (Text.unpack (Text.concat ["https://login.microsoftonline.com/", uuidToText (azureTenantId creds), "/oatuh2/token"]))+ $ buildFormParams "https://outlook.office365.com/"+ privateKey+ fingerPrint+ clientId+ tenantId+ requestId+ now+ t <- throwFromJust "Could not get an access token" $ r ^? responseBody . key "access_token" . _String+ pure $ AzureToken t++buildFormParams :: Text -> PrivateKey -> Text -> UUID -> UUID -> UUID -> UTCTime -> [FormParam]+buildFormParams resource privateKey base64Fingerprint clientId tenantId requestId now =+ [ "grant_type" := asText "client_credentials"+ , "resource" := resource+ , "client_id" := uuidToText clientId+ , "client_assertion_type" := asText "urn:ietf:params:oauth:client-assertion-type:jwt-bearer"+ , "client_assertion" := buildAssertion privateKey base64Fingerprint clientId tenantId requestId now+ ]++newtype AzureToken = AzureToken { getAzureToken :: Text }++data AzureCreds = AzureCreds+ { azureClientId :: !UUID+ , azureTenantId :: !UUID+ , azureFingerprint :: !Text+ , azurePrivateKey :: !PrivateKey+ }++fromRightErr :: String -> Either a b -> b+fromRightErr err = \case+ Left _ -> error err+ Right b -> b++throwFromJust :: MonadThrow m => String -> Maybe a -> m a+throwFromJust err = \case+ Just a -> pure a+ Nothing -> throwM (MyException err)++data MyException = MyException String+ deriving (Show, Eq)+instance Exception MyException