{-# 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

-- | @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
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 -- ^ 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
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"

-- | @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
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
            }

-- |
--
-- 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

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"