ses-html (empty) → 0.1.0.0
raw patch · 4 files changed
+294/−0 lines, 4 filesdep +HsOpenSSLdep +basedep +base64-bytestringsetup-changed
Dependencies added: HsOpenSSL, base, base64-bytestring, blaze-html, byteable, bytestring, cryptohash, http-streams, old-locale, tagsoup, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- ses-html.cabal +29/−0
- src/Network/SES.hs +233/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ses-html.cabal view
@@ -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
+ src/Network/SES.hs view
@@ -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 +-- +-- <http://s3.amazonaws.com/awsdocs/ses/latest/ses-api.pdf>+--+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)+