Proper error checking (fixes snoyberg#20)

k0ral · Feb 20, 2014 · 72c3d1f · 72c3d1f
1 parent 5328d5b
commit 72c3d1f
Show file tree

Hide file tree

Showing 2 changed files with 95 additions and 37 deletions.
diff --git 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
@@ -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