From 72c3d1ff0024d6dba81ad9739e49521307c4fd07 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 20 Feb 2014 10:04:38 +0200 Subject: [PATCH] Proper error checking (fixes #20) --- mime-mail-ses/Network/Mail/Mime/SES.hs | 120 ++++++++++++++++++------- mime-mail-ses/mime-mail-ses.cabal | 12 +-- 2 files changed, 95 insertions(+), 37 deletions(-) diff --git a/mime-mail-ses/Network/Mail/Mime/SES.hs b/mime-mail-ses/Network/Mail/Mime/SES.hs index a2de794..6a920c0 100644 --- a/mime-mail-ses/Network/Mail/Mime/SES.hs +++ b/mime-mail-ses/Network/Mail/Mime/SES.hs @@ -1,62 +1,70 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Mail.Mime.SES ( sendMailSES , renderSendMailSES , SES (..) ) where -import Data.ByteString (ByteString) -import Network.Mail.Mime (Mail, renderMail') -import qualified Data.ByteString.Lazy as L -import Network.HTTP.Conduit (httpLbs, Manager, parseUrl, requestHeaders, urlEncodedBody) -import Data.Time.Format (formatTime) -import System.Locale (defaultTimeLocale) -import Data.Time (getCurrentTime) -import qualified Data.ByteString.Char8 as S8 -import Crypto.HMAC -#if MIN_VERSION_cryptohash(0, 10, 0) -import Crypto.Hash.CryptoAPI (SHA256) -#else -import Crypto.Hash.SHA256 (SHA256) -#endif -import Data.ByteString.Base64 (encode) -import qualified Data.Serialize as S -import Control.Monad.Trans.Resource (MonadResource) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.IO.Class (liftIO) +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash.CryptoAPI (SHA256) +import Crypto.HMAC +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 qualified Data.Serialize as S +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, checkStatus, parseUrl, + requestHeaders, responseBody, + responseStatus, urlEncodedBody, + withResponse) +import Network.HTTP.Client.Conduit (bodyReaderSource) +import Network.HTTP.Types (Status) +import Network.Mail.Mime (Mail, renderMail') +import System.Locale (defaultTimeLocale) +import Text.XML.Stream.Parse (def, parseBytes) data SES = SES - { sesFrom :: ByteString - , sesTo :: [ByteString] + { sesFrom :: ByteString + , sesTo :: [ByteString] , sesAccessKey :: ByteString , sesSecretKey :: ByteString } -renderSendMailSES :: (MonadBaseControl IO m, MonadResource m) => Manager -> SES -> Mail -> m () +renderSendMailSES :: MonadIO m => Manager -> SES -> Mail -> m () renderSendMailSES m ses mail = liftIO (renderMail' mail) >>= sendMailSES m ses -sendMailSES :: (MonadBaseControl IO m, MonadResource m) => Manager -> SES -> L.ByteString -> m () -sendMailSES manager ses msg = do - now <- liftIO getCurrentTime +sendMailSES :: MonadIO m => Manager -> SES -> L.ByteString -> m () +sendMailSES manager ses msg = liftIO $ do + now <- getCurrentTime let date = S8.pack $ format now sig = makeSig date $ sesSecretKey ses - req' <- liftIO $ parseUrl "https://email.us-east-1.amazonaws.com" + req' <- parseUrl "https://email.us-east-1.amazonaws.com" let auth = S8.concat [ "AWS3-HTTPS AWSAccessKeyId=" , sesAccessKey ses , ", Algorithm=HmacSHA256, Signature=" , sig ] - let req = req' + let req = urlEncodedBody qs $ req' { requestHeaders = [ ("Date", date) , ("X-Amzn-Authorization", auth) ] + , checkStatus = \_ _ _ -> Nothing } - _ <- flip httpLbs manager $ urlEncodedBody qs req - return () + withResponse req manager $ \res -> + bodyReaderSource (responseBody res) + $$ parseBytes def + =$ checkForError (responseStatus res) where qs = ("Action", "SendRawEmail") @@ -66,6 +74,54 @@ sendMailSES manager ses msg = do mkDest num addr = (S8.pack $ "Destinations.member." ++ show num, addr) format = formatTime defaultTimeLocale "%a, %e %b %Y %H:%M:%S %z" +checkForError :: Status -> Sink Event IO () +checkForError status = do + name <- getFirstStart + if name == errorResponse + then loop "" "" "" + else return () + where + errorResponse = "{http://ses.amazonaws.com/doc/2010-12-01/}ErrorResponse" + getFirstStart = do + mx <- await + case mx of + Nothing -> return errorResponse + Just (EventBeginElement name _) -> return name + _ -> getFirstStart + loop code msg reqid = + await >>= maybe finish go + where + getContent front = do + mx <- await + case mx of + Just (EventContent (ContentText t)) -> getContent (front . (t:)) + _ -> return $ T.concat $ front [] + go (EventBeginElement "{http://ses.amazonaws.com/doc/2010-12-01/}Code" _) = do + t <- getContent id + loop t msg reqid + go (EventBeginElement "{http://ses.amazonaws.com/doc/2010-12-01/}Message" _) = do + t <- getContent id + loop code t reqid + go (EventBeginElement "{http://ses.amazonaws.com/doc/2010-12-01/}RequestId" _) = do + t <- getContent id + loop code msg t + go _ = loop code msg reqid + finish = liftIO $ throwIO SESException + { seStatus = status + , seCode = code + , seMessage = msg + , seRequestId = reqid + } + +data SESException = SESException + { seStatus :: !Status + , seCode :: !Text + , seMessage :: !Text + , seRequestId :: !Text + } + deriving (Show, Typeable) +instance Exception SESException + makeSig :: ByteString -> ByteString -> ByteString makeSig payload key = encode diff --git a/mime-mail-ses/mime-mail-ses.cabal b/mime-mail-ses/mime-mail-ses.cabal index 4ad2acd..5f04da0 100644 --- a/mime-mail-ses/mime-mail-ses.cabal +++ b/mime-mail-ses/mime-mail-ses.cabal @@ -1,5 +1,5 @@ Name: mime-mail-ses -Version: 0.2.1.3 +Version: 0.2.2 Synopsis: Send mime-mail messages via Amazon SES Homepage: http://github.com/snoyberg/mime-mail License: MIT @@ -16,15 +16,17 @@ Library , crypto-api >= 0.6 , cereal >= 0.3 , base64-bytestring >= 0.1 - , cryptohash >= 0.7 , bytestring >= 0.9 , time >= 1.1 , old-locale - , http-conduit >= 1.4 + , http-client >= 0.2.2.2 + , http-client-conduit>= 0.2.0.1 , mime-mail >= 0.3 - , resourcet >= 0.3 , transformers >= 0.2 , http-types >= 0.6.8 - , monad-control >= 0.3 , cryptohash-cryptoapi + , xml-conduit + , xml-types + , text + , conduit ghc-options: -Wall