{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Network.Mail.Mime.SES
( sendMailSES
, sendMailSESGlobal
, renderSendMailSES
, renderSendMailSESGlobal
, SES (..)
, usEast1
, usWest2
, euWest1
, SESException (..)
) where
import Control.Exception (Exception, throwIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Hash (Digest, SHA256, hmac,
hmacGetDigest)
import Data.Byteable (toBytes)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (encode)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Sink, await, ($$), (=$))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Typeable (Typeable)
import Data.XML.Types (Content (ContentText), Event (EventBeginElement, EventContent))
import Network.HTTP.Client (Manager,
#if MIN_VERSION_http_client(0, 5, 0)
parseRequest,
#else
checkStatus,
parseUrl,
#endif
requestHeaders, responseBody,
responseStatus, urlEncodedBody,
withResponse)
import Network.HTTP.Client.Conduit (bodyReaderSource)
import Network.HTTP.Types (Status)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Mail.Mime (Mail, renderMail')
import Text.XML.Stream.Parse (def, parseBytes)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
data SES = SES
{ SES -> ByteString
sesFrom :: !ByteString
, SES -> [ByteString]
sesTo :: ![ByteString]
, SES -> ByteString
sesAccessKey :: !ByteString
, SES -> ByteString
sesSecretKey :: !ByteString
, SES -> Maybe ByteString
sesSessionToken :: !(Maybe ByteString)
, SES -> Text
sesRegion :: !Text
}
deriving Int -> SES -> ShowS
[SES] -> ShowS
SES -> String
(Int -> SES -> ShowS)
-> (SES -> String) -> ([SES] -> ShowS) -> Show SES
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SES] -> ShowS
$cshowList :: [SES] -> ShowS
show :: SES -> String
$cshow :: SES -> String
showsPrec :: Int -> SES -> ShowS
$cshowsPrec :: Int -> SES -> ShowS
Show
renderSendMailSES :: MonadIO m => Manager -> SES -> Mail -> m ()
renderSendMailSES :: Manager -> SES -> Mail -> m ()
renderSendMailSES m :: Manager
m ses :: SES
ses mail :: Mail
mail = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Mail -> IO ByteString
renderMail' Mail
mail) m ByteString -> (ByteString -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Manager -> SES -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
Manager -> SES -> ByteString -> m ()
sendMailSES Manager
m SES
ses
renderSendMailSESGlobal :: MonadIO m => SES -> Mail -> m ()
renderSendMailSESGlobal :: SES -> Mail -> m ()
renderSendMailSESGlobal ses :: SES
ses mail :: Mail
mail = do
Manager
mgr <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
getGlobalManager
Manager -> SES -> Mail -> m ()
forall (m :: * -> *). MonadIO m => Manager -> SES -> Mail -> m ()
renderSendMailSES Manager
mgr SES
ses Mail
mail
sendMailSES :: MonadIO m => Manager -> SES
-> L.ByteString
-> m ()
sendMailSES :: Manager -> SES -> ByteString -> m ()
sendMailSES manager :: Manager
manager ses :: SES
ses msg :: ByteString
msg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
now <- IO UTCTime
getCurrentTime
let date :: ByteString
date = String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
format UTCTime
now
sig :: ByteString
sig = ByteString -> ByteString -> ByteString
makeSig ByteString
date (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SES -> ByteString
sesSecretKey SES
ses
region :: String
region = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SES -> Text
sesRegion SES
ses
#if MIN_VERSION_http_client(0, 5, 0)
Request
req' <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["https://email.", String
region , ".amazonaws.com"]
#else
req' <- parseUrl $ concat ["https://email.", region , ".amazonaws.com"]
#endif
let auth :: ByteString
auth = [ByteString] -> ByteString
S8.concat
[ "AWS3-HTTPS AWSAccessKeyId="
, SES -> ByteString
sesAccessKey SES
ses
, ", Algorithm=HmacSHA256, Signature="
, ByteString
sig
]
let req :: Request
req = [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
qs (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req'
{ requestHeaders :: RequestHeaders
requestHeaders =
[ ("Date", ByteString
date)
, ("X-Amzn-Authorization", ByteString
auth)
] RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ case SES -> Maybe ByteString
sesSessionToken SES
ses of
Just token :: ByteString
token -> [("X-Amz-Security-Token", ByteString
token)]
Nothing -> []
#if !MIN_VERSION_http_client(0, 5, 0)
, checkStatus = \_ _ _ -> Nothing
#endif
}
Request -> Manager -> (Response BodyReader -> IO ()) -> IO ()
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
manager ((Response BodyReader -> IO ()) -> IO ())
-> (Response BodyReader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \res :: Response BodyReader
res ->
BodyReader -> ConduitM () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
BodyReader -> ConduitM i ByteString m ()
bodyReaderSource (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
res)
ConduitM () ByteString IO () -> Sink ByteString IO () -> IO ()
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ ParseSettings -> ConduitT ByteString Event IO ()
forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT ByteString Event m ()
parseBytes ParseSettings
forall a. Default a => a
def
ConduitT ByteString Event IO ()
-> ConduitT Event Void IO () -> Sink ByteString IO ()
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ Status -> ConduitT Event Void IO ()
checkForError (Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
res)
where
qs :: [(ByteString, ByteString)]
qs =
("Action", "SendRawEmail")
(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ("Source", SES -> ByteString
sesFrom SES
ses)
(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ("RawMessage.Data", ByteString -> ByteString
encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
msg)
(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: (Int -> ByteString -> (ByteString, ByteString))
-> [Int] -> [ByteString] -> [(ByteString, ByteString)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ByteString -> (ByteString, ByteString)
forall a b. Show a => a -> b -> (ByteString, b)
mkDest [1 :: Int ..] (SES -> [ByteString]
sesTo SES
ses)
mkDest :: a -> b -> (ByteString, b)
mkDest num :: a
num addr :: b
addr = (String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "Destinations.member." String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
num, b
addr)
format :: UTCTime -> String
format = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%a, %e %b %Y %H:%M:%S %z"
sendMailSESGlobal :: MonadIO m => SES
-> L.ByteString
-> m ()
sendMailSESGlobal :: SES -> ByteString -> m ()
sendMailSESGlobal ses :: SES
ses msg :: ByteString
msg = do
Manager
mgr <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
getGlobalManager
Manager -> SES -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
Manager -> SES -> ByteString -> m ()
sendMailSES Manager
mgr SES
ses ByteString
msg
checkForError :: Status -> Sink Event IO ()
checkForError :: Status -> ConduitT Event Void IO ()
checkForError status :: Status
status = do
Name
name <- ConduitT Event Void IO Name
forall o. ConduitT Event o IO Name
getFirstStart
if Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorResponse
then Text -> Text -> Text -> ConduitT Event Void IO ()
forall (m :: * -> *) o b.
MonadIO m =>
Text -> Text -> Text -> ConduitT Event o m b
loop "" "" ""
else () -> ConduitT Event Void IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
errorResponse :: Name
errorResponse = "{http://ses.amazonaws.com/doc/2010-12-01/}ErrorResponse"
getFirstStart :: ConduitT Event o IO Name
getFirstStart = do
Maybe Event
mx <- ConduitT Event o IO (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
case Maybe Event
mx of
Nothing -> Name -> ConduitT Event o IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
errorResponse
Just (EventBeginElement name :: Name
name _) -> Name -> ConduitT Event o IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
_ -> ConduitT Event o IO Name
getFirstStart
loop :: Text -> Text -> Text -> ConduitT Event o m b
loop code :: Text
code msg :: Text
msg reqid :: Text
reqid =
ConduitT Event o m (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT Event o m (Maybe Event)
-> (Maybe Event -> ConduitT Event o m b) -> ConduitT Event o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT Event o m b
-> (Event -> ConduitT Event o m b)
-> Maybe Event
-> ConduitT Event o m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConduitT Event o m b
forall a. ConduitT Event o m a
finish Event -> ConduitT Event o m b
go
where
getContent :: ([Text] -> [Text]) -> ConduitT Event o m Text
getContent front :: [Text] -> [Text]
front = do
Maybe Event
mx <- ConduitT Event o m (Maybe Event)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
case Maybe Event
mx of
Just (EventContent (ContentText t :: Text
t)) -> ([Text] -> [Text]) -> ConduitT Event o m Text
getContent ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
tText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
_ -> Text -> ConduitT Event o m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ConduitT Event o m Text)
-> Text -> ConduitT Event o m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []
go :: Event -> ConduitT Event o m b
go (EventBeginElement "{http://ses.amazonaws.com/doc/2010-12-01/}Code" _) = do
Text
t <- ([Text] -> [Text]) -> ConduitT Event o m Text
forall (m :: * -> *) o.
Monad m =>
([Text] -> [Text]) -> ConduitT Event o m Text
getContent [Text] -> [Text]
forall a. a -> a
id
Text -> Text -> Text -> ConduitT Event o m b
loop Text
t Text
msg Text
reqid
go (EventBeginElement "{http://ses.amazonaws.com/doc/2010-12-01/}Message" _) = do
Text
t <- ([Text] -> [Text]) -> ConduitT Event o m Text
forall (m :: * -> *) o.
Monad m =>
([Text] -> [Text]) -> ConduitT Event o m Text
getContent [Text] -> [Text]
forall a. a -> a
id
Text -> Text -> Text -> ConduitT Event o m b
loop Text
code Text
t Text
reqid
go (EventBeginElement "{http://ses.amazonaws.com/doc/2010-12-01/}RequestId" _) = do
Text
t <- ([Text] -> [Text]) -> ConduitT Event o m Text
forall (m :: * -> *) o.
Monad m =>
([Text] -> [Text]) -> ConduitT Event o m Text
getContent [Text] -> [Text]
forall a. a -> a
id
Text -> Text -> Text -> ConduitT Event o m b
loop Text
code Text
msg Text
t
go _ = Text -> Text -> Text -> ConduitT Event o m b
loop Text
code Text
msg Text
reqid
finish :: ConduitT Event o m a
finish = IO a -> ConduitT Event o m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ConduitT Event o m a) -> IO a -> ConduitT Event o m a
forall a b. (a -> b) -> a -> b
$ SESException -> IO a
forall e a. Exception e => e -> IO a
throwIO $WSESException :: Status -> Text -> Text -> Text -> SESException
SESException
{ seStatus :: Status
seStatus = Status
status
, seCode :: Text
seCode = Text
code
, seMessage :: Text
seMessage = Text
msg
, seRequestId :: Text
seRequestId = Text
reqid
}
data SESException = SESException
{ SESException -> Status
seStatus :: !Status
, SESException -> Text
seCode :: !Text
, SESException -> Text
seMessage :: !Text
, SESException -> Text
seRequestId :: !Text
}
deriving (Int -> SESException -> ShowS
[SESException] -> ShowS
SESException -> String
(Int -> SESException -> ShowS)
-> (SESException -> String)
-> ([SESException] -> ShowS)
-> Show SESException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SESException] -> ShowS
$cshowList :: [SESException] -> ShowS
show :: SESException -> String
$cshow :: SESException -> String
showsPrec :: Int -> SESException -> ShowS
$cshowsPrec :: Int -> SESException -> ShowS
Show, Typeable)
instance Exception SESException
makeSig :: ByteString -> ByteString -> ByteString
makeSig :: ByteString -> ByteString -> ByteString
makeSig payload :: ByteString
payload key :: ByteString
key =
ByteString -> ByteString
encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall a. Byteable a => a -> ByteString
toBytes (HMAC SHA256 -> Digest SHA256
forall a. HMAC a -> Digest a
hmacGetDigest (HMAC SHA256 -> Digest SHA256) -> HMAC SHA256 -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HMAC SHA256
forall a. HashAlgorithm a => ByteString -> ByteString -> HMAC a
hmac ByteString
key ByteString
payload :: Digest SHA256)
usEast1 :: Text
usEast1 :: Text
usEast1 = "us-east-1"
usWest2 :: Text
usWest2 :: Text
usWest2 = "us-west-2"
euWest1 :: Text
euWest1 :: Text
euWest1 = "eu-west-1"