module Network.SES
(
sendEmailBlaze
, sendEmail
, From
, To
, Subject
, PublicKey (..)
, SecretKey (..)
, Region (..)
, SESErrorType (..)
, SESError (..)
, SESErrorCode
, SESErrorMessage
) where
import Crypto.Hash ( Digest, SHA256
, hmac, hmacGetDigest
)
import Data.Byteable ( toBytes )
import Data.ByteString (ByteString)
import Data.ByteString.Char8 ( pack, unpack, concat )
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Base64 ( encode )
import Data.Monoid ( (<>) )
import Data.Maybe ( fromMaybe )
import Data.Time.Clock ( getCurrentTime )
import Data.Time.Format ( formatTime )
import Network.Http.Client ( buildRequest, http, Method(POST), setContentType
, setHeader,baselineContextSSL, openConnectionSSL
, Connection, sendRequest, encodedFormBody
, receiveResponse, closeConnection, getStatusCode
, concatHandler, getStatusCode
)
import OpenSSL ( withOpenSSL )
import Prelude hiding ( concat )
import System.Locale ( defaultTimeLocale )
import Text.Blaze.Html.Renderer.Utf8 ( renderHtml )
import Text.Blaze.Html5 ( Html )
import Text.Read ( readMaybe )
import Control.Exception ( try, SomeException )
import Text.HTML.TagSoup ( parseTags, Tag(..) )
type ConnectionError a = IO (Either SomeException a)
type Subject = L.ByteString
type From = L.ByteString
type To = [L.ByteString]
newtype PublicKey = PublicKey ByteString deriving (Show, Eq)
newtype SecretKey = SecretKey ByteString deriving (Show, Eq)
data Region = USEast1
| USWest2
| EUWest1
instance Show Region where
show USEast1 = "us-east-1"
show USWest2 = "us-west-2"
show EUWest1 = "eu-west-1"
sendEmailBlaze
:: PublicKey
-> SecretKey
-> Region
-> From
-> To
-> Subject
-> Html
-> IO (Either SESError ())
sendEmailBlaze
publicKey
secretKey
region
from
to
subject
html = sendEmail publicKey secretKey region from to subject (renderHtml html)
sendEmail
:: PublicKey
-> SecretKey
-> Region
-> From
-> To
-> Subject
-> L.ByteString
-> IO (Either SESError ())
sendEmail = makeRequest
type SESErrorCode = Int
type SESErrorMessage = ByteString
data SESError =
SESConnectionError ByteString
| SESError SESErrorCode SESErrorType SESErrorMessage
deriving (Show)
data SESErrorType =
IncompleteSignature
| InternalFailure
| InvalidAction
| InvalidClientTokenId
| InvalidParameterCombination
| InvalidParameterValue
| InvalidQueryParameter
| MalformedQueryString
| MissingAction
| MissingAuthenticationToken
| SignatureDoesNotMatch
| MissingParameter
| MessageRejected
| OptInRequired
| RequestExpired
| ServiceUnavailable
| Throttling
| UnknownErrorType
| ValidationError
deriving (Show, Read)
makeRequest
:: PublicKey
-> SecretKey
-> Region
-> From
-> To
-> Subject
-> L.ByteString
-> IO (Either SESError ())
makeRequest
(PublicKey publicKey)
(SecretKey secretKey)
region
from
to
subject
msg = withOpenSSL $ do
now <- getCurrentTime
let date = pack $ format now
sig = makeSig date secretKey
format = formatTime defaultTimeLocale "%a, %e %b %Y %H:%M:%S %z"
auth = concat
[ "AWS3-HTTPS AWSAccessKeyId="
, publicKey
, ", Algorithm=HmacSHA256, Signature="
, sig
]
queryString =
("Action", "SendEmail")
: ("Source", L.toStrict from)
: ("Message.Subject.Data", L.toStrict subject)
: ("Message.Body.Html.Data", L.toStrict msg)
: zipWith mkDest [1 :: Int ..] to
mkDest num addr = (pack $ "Destination.ToAddresses.member." ++ show num, L.toStrict addr)
req <- buildRequest $ do
http POST "/"
setContentType "application/x-www-form-urlencoded"
setHeader "X-Amzn-Authorization" auth
setHeader "Date" date
ctx <- baselineContextSSL
let
connResult <- try (openConnectionSSL ctx ("email." <> pack (show region) <> ".amazonaws.com") 443)
:: ConnectionError Connection
case connResult of
Left s -> connectionError s
Right con -> do
result <- try (sendRequest con req $ encodedFormBody queryString) :: ConnectionError ()
case result of
Left s -> connectionError s
Right _ -> do
receiveResponse con $ \resp is ->
do closeConnection con
if getStatusCode resp == 200
then returnSuccess
else do bs <- concatHandler resp is
let tags = parseTags bs
code = let c = getFromTagSoup "Code" tags
in fromMaybe UnknownErrorType (readMaybe (unpack c) :: Maybe SESErrorType)
sesMsg = getFromTagSoup "Message" tags
return $ Left $ SESError (getStatusCode resp) code sesMsg
where
getFromTagSoup x tags = let [ _, TagText d] = filterFront . filterBack $ tags
filterFront = dropWhile (/=(TagOpen x []))
filterBack = takeWhile (/=(TagClose x))
in d
connectionError = return . Left . SESConnectionError . pack . show
returnSuccess = return $ Right ()
makeSig
:: ByteString
-> ByteString
-> ByteString
makeSig payload key =
encode $ toBytes (hmacGetDigest $ hmac key payload :: Digest SHA256)