mime-mail-ses 0.2.1.3 → 0.2.2
raw patch · 2 files changed
+95/−37 lines, 2 filesdep +conduitdep +http-clientdep +http-client-conduitdep −cryptohashdep −http-conduitdep −monad-control
Dependencies added: conduit, http-client, http-client-conduit, text, xml-conduit, xml-types
Dependencies removed: cryptohash, http-conduit, monad-control, resourcet
Files
- Network/Mail/Mime/SES.hs +88/−32
- mime-mail-ses.cabal +7/−5
Network/Mail/Mime/SES.hs view
@@ -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")@@ -65,6 +73,54 @@ : zipWith mkDest [1 :: Int ..] (sesTo ses) 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 =
mime-mail-ses.cabal view
@@ -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 @@ , 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