{-# 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           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 qualified Data.Text.Encoding          as E
import           Data.Time                   (getCurrentTime)
import           Data.Typeable               (Typeable)
import           Data.XML.Types              (Content (ContentText), Event (EventBeginElement, EventContent))
import           Network.HTTP.Client         (Manager,
                                              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)

import Network.Mail.Mime.SES.Internal

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 Manager
m SES
ses 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

-- | @since 0.4.1
-- Same as 'renderSendMailSES' but uses the global 'Manager'.
renderSendMailSESGlobal :: MonadIO m => SES -> Mail -> m ()
renderSendMailSESGlobal :: SES -> Mail -> m ()
renderSendMailSESGlobal SES
ses 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 -- ^ Raw message data. You must ensure that
                            -- the message format complies with
                            -- Internet email standards regarding
                            -- email header fields, MIME types, and
                            -- MIME encoding.
            -> m ()
sendMailSES :: Manager -> SES -> ByteString -> m ()
sendMailSES Manager
manager SES
ses 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
    Request
requestBase <- String -> IO Request
buildRequest ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"https://email.", Text -> String
T.unpack (SES -> Text
sesRegion SES
ses) , String
".amazonaws.com"])
    let headers :: [(HeaderName, ByteString)]
headers =
          [ (HeaderName
"Date", UTCTime -> ByteString
formatAmazonTime UTCTime
now)
          ]
          [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. [a] -> [a] -> [a]
++ case SES -> Maybe ByteString
sesSessionToken SES
ses of
               Just ByteString
token -> [(HeaderName
"X-Amz-Security-Token", ByteString
token)]
               Maybe ByteString
Nothing    -> []
    let tentativeRequest :: Request
tentativeRequest = [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
qs (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
requestBase {requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
headers}
        canonicalRequest :: ByteString
canonicalRequest = Request -> ByteString
canonicalizeRequest Request
tentativeRequest
        stringToSign :: ByteString
stringToSign = ByteString -> UTCTime -> ByteString -> ByteString -> ByteString
makeStringToSign ByteString
"ses" UTCTime
now (Text -> ByteString
E.encodeUtf8 (SES -> Text
sesRegion SES
ses)) ByteString
canonicalRequest
        sig :: ByteString
sig = ByteString
-> UTCTime -> ByteString -> ByteString -> ByteString -> ByteString
makeSig ByteString
"ses" UTCTime
now (Text -> ByteString
E.encodeUtf8 (SES -> Text
sesRegion SES
ses)) (SES -> ByteString
sesSecretKey SES
ses) ByteString
stringToSign
        authorizationString :: ByteString
authorizationString = ByteString
-> UTCTime
-> ByteString
-> [(HeaderName, ByteString)]
-> ByteString
-> ByteString
-> ByteString
makeAuthorizationString ByteString
"ses" UTCTime
now (Text -> ByteString
E.encodeUtf8 (SES -> Text
sesRegion SES
ses))
                              (Request -> [(HeaderName, ByteString)]
patchedRequestHeaders Request
tentativeRequest) (SES -> ByteString
sesAccessKey SES
ses) ByteString
sig
        finalRequest :: Request
finalRequest = Request
tentativeRequest {requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = (HeaderName
"Authorization", ByteString
authorizationString)(HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: Request -> [(HeaderName, ByteString)]
requestHeaders Request
tentativeRequest}
    Request -> Manager -> (Response BodyReader -> IO ()) -> IO ()
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
finalRequest Manager
manager ((Response BodyReader -> IO ()) -> IO ())
-> (Response BodyReader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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 =
          (ByteString
"Action", ByteString
"SendRawEmail")
        (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: (ByteString
"Source", SES -> ByteString
sesFrom SES
ses)
        (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: (ByteString
"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 [Int
1 :: Int ..] (SES -> [ByteString]
sesTo SES
ses)
    mkDest :: a -> b -> (ByteString, b)
mkDest a
num b
addr = (String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"Destinations.member." String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
num, b
addr)

-- | @since 0.4.1
-- Same as 'sendMailSES' but uses the global 'Manager'.
sendMailSESGlobal :: MonadIO m => SES 
                  -> L.ByteString -- ^ Raw message data. You must ensure that
                                  -- the message format complies with
                                  -- Internet email standards regarding
                                  -- email header fields, MIME types, and
                                  -- MIME encoding.
                  -> m ()
sendMailSESGlobal :: SES -> ByteString -> m ()
sendMailSESGlobal SES
ses 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 = 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 Text
"" Text
"" Text
""
        else () -> ConduitT Event Void IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    errorResponse :: Name
errorResponse = Name
"{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
            Maybe Event
Nothing -> Name -> ConduitT Event o IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
errorResponse
            Just (EventBeginElement Name
name [(Name, [Content])]
_) -> Name -> ConduitT Event o IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
            Maybe Event
_ -> ConduitT Event o IO Name
getFirstStart
    loop :: Text -> Text -> Text -> ConduitT Event o m b
loop Text
code Text
msg 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 [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 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]
:))
                Maybe Event
_ -> 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 Name
"{http://ses.amazonaws.com/doc/2010-12-01/}Code" [(Name, [Content])]
_) = 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 Name
"{http://ses.amazonaws.com/doc/2010-12-01/}Message" [(Name, [Content])]
_) = 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 Name
"{http://ses.amazonaws.com/doc/2010-12-01/}RequestId" [(Name, [Content])]
_) = 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 Event
_ = 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 SESException :: 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
            }

-- |
--
-- Exposed since: 0.3.2
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

usEast1 :: Text
usEast1 :: Text
usEast1 = Text
"us-east-1"

usWest2 :: Text
usWest2 :: Text
usWest2 = Text
"us-west-2"

euWest1 :: Text
euWest1 :: Text
euWest1 = Text
"eu-west-1"