diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2014, David Johnson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ses-html.cabal b/ses-html.cabal new file mode 100644 --- /dev/null +++ b/ses-html.cabal @@ -0,0 +1,29 @@ +name: ses-html +version: 0.1.0.0 +synopsis: Send html emails written in Haskell +license: BSD3 +license-file: LICENSE +author: David Johnson +maintainer: djohnson.m@gmail.com +copyright: David Johnson +category: Web, AWS, Email +build-type: Simple +cabal-version: >=1.10 +description: Send html emails using Amazon's Simple Email Service and Blaze Templating in Haskell + +library + exposed-modules: Network.SES + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-binds + build-depends: base >=4.7 && <4.8 + , base64-bytestring + , blaze-html + , bytestring + , byteable + , cryptohash + , http-streams + , HsOpenSSL + , old-locale + , tagsoup + , time diff --git a/src/Network/SES.hs b/src/Network/SES.hs new file mode 100644 --- /dev/null +++ b/src/Network/SES.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.SES + ( -- * Email creation + sendEmailBlaze + , sendEmail + -- * Types + , 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(..) ) + +------------------------------------------------------------------------------ +-- | Types for Email creation +type ConnectionError a = IO (Either SomeException a) +type Subject = L.ByteString +type From = L.ByteString +type To = [L.ByteString] + +------------------------------------------------------------------------------ +-- | Types for AWS Keys +newtype PublicKey = PublicKey ByteString deriving (Show, Eq) +newtype SecretKey = SecretKey ByteString deriving (Show, Eq) + +------------------------------------------------------------------------------ +-- | Types for AWS 'Region's +data Region = USEast1 -- ^ US East 1 Region + | USWest2 -- ^ US West 2 Region + | EUWest1 -- ^ EU West 1 Region + +------------------------------------------------------------------------------ +-- | Custome 'Show' instance for 'Region' +instance Show Region where + show USEast1 = "us-east-1" + show USWest2 = "us-west-2" + show EUWest1 = "eu-west-1" +------------------------------------------------------------------------------ +-- | Send Emails templated with Blaze using SES +-- +-- > main :: IO () +-- > main = print =<< sendEmailBlaze publicKey secretKey region from to subject html +-- > where +-- > publicKey = PublicKey "public key goes here" +-- > secretKey = SecretKey "secret key goes here" +-- > region = USEast1 +-- > from = "verifiedSender@domain.com" +-- > to = ["recipient@domain.com"] +-- > subject = "Test Subject" +-- > html = H.html $ do +-- > H.body $ do +-- > H.h1 "Html email!" +-- +sendEmailBlaze + :: PublicKey -- ^ AWS Public Key + -> SecretKey -- ^ AWS Secret Key + -> Region -- ^ The Region to send the Request + -> From -- ^ The Email sender + -> To -- ^ The Email recipient + -> Subject -- ^ The Subject of the Email + -> Html -- ^ The Html of the email body + -> IO (Either SESError ()) +sendEmailBlaze + publicKey + secretKey + region + from + to + subject + html = sendEmail publicKey secretKey region from to subject (renderHtml html) + +------------------------------------------------------------------------------ +-- | Send emails without using Blaze, raw bytes are expected to be valid HTML +sendEmail + :: PublicKey -- ^ AWS Public Key + -> SecretKey -- ^ AWS Secret Key + -> Region -- ^ The Region to send the Request + -> From -- ^ The Email sender + -> To -- ^ The Email recipient + -> Subject -- ^ The Subject of the Email + -> L.ByteString -- ^ Raw Html + -> IO (Either SESError ()) +sendEmail = makeRequest + +------------------------------------------------------------------------------ +-- | Types to hold SES Errors +type SESErrorCode = Int -- ^ Error Code returned from SES XML response +type SESErrorMessage = ByteString -- ^ Error Message returned from SES Message +data SESError = + -- | Connection Error, can occur on open & close or on send & receive of a Request or Response + SESConnectionError ByteString + -- | If a request is made successfully but the parameters specifed were incorrect + | SESError SESErrorCode SESErrorType SESErrorMessage + deriving (Show) + +------------------------------------------------------------------------------ +-- | Common Error Types for SES +-- +-- +-- +data SESErrorType = + IncompleteSignature + | InternalFailure + | InvalidAction + | InvalidClientTokenId + | InvalidParameterCombination + | InvalidParameterValue + | InvalidQueryParameter + | MalformedQueryString + | MissingAction + | MissingAuthenticationToken + | SignatureDoesNotMatch + | MissingParameter + | MessageRejected + | OptInRequired + | RequestExpired + | ServiceUnavailable + | Throttling + | UnknownErrorType + | ValidationError + deriving (Show, Read) + +------------------------------------------------------------------------------ +-- | SES Request Dispatcher +makeRequest + :: PublicKey -- ^ AWS Public Key + -> SecretKey -- ^ AWS Secret Key + -> Region -- ^ The Region to send the Request + -> From -- ^ The Email sender + -> To -- ^ The Email recipient + -> Subject -- ^ The Subject of the Email + -> L.ByteString -- ^ Raw Html + -> 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 () + +------------------------------------------------------------------------------ +-- | Digital Signature creation +makeSig + :: ByteString -- ^ Payload + -> ByteString -- ^ Key + -> ByteString +makeSig payload key = + encode $ toBytes (hmacGetDigest $ hmac key payload :: Digest SHA256) +