amazon-emailer (empty) → 0.3.0.0

raw patch · 4 files changed

+153/−0 lines, 4 filesdep +basedep +bytestringdep +http-conduitsetup-changed

Dependencies added: base, bytestring, http-conduit, lifted-base, mime-mail, mime-mail-ses, postgresql-simple, resourcet, text, time

Files

• LICENSE +30/−0
• Mailer.hs +89/−0
• Setup.hs +2/−0
• amazon-emailer.cabal +32/−0

@@ -0,0 +1,30 @@+Copyright (c) 2013, Daniel Patterson++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 Daniel Patterson 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.

@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import Control.Monad (forM, replicateM)+import Control.Monad.Trans.Resource (runResourceT)+import Control.Concurrent (threadDelay)+import Control.Exception (bracket)+import qualified Control.Exception.Lifted as EX+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import qualified Data.Text.Encoding as T+import Data.Time.Clock (UTCTime, getCurrentTime)++import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow+import Network.HTTP.Conduit (Manager(..), newManager, closeManager, conduitManagerSettings)+import Network.Mail.Mime (Mail(..), Address(..), Part(..), Encoding (QuotedPrintableText))+import Network.Mail.Mime.SES++import Config (configHost, configUser, configPass, +               configDB, configAccessKey,+               configSecretKey, configLimit)++main :: IO ()+main =+  bracket ((,) <$> (connect $ defaultConnectInfo { connectHost = configHost,+                                                   connectUser = configUser,+                                                   connectPassword = configPass,+                                                   connectDatabase = configDB })+               <*> (newManager conduitManagerSettings))+    (\(c,m) -> close c >> closeManager m)+    (\(c,m) -> runQueue c m)++data AmEmail = AmEmail { aId :: Int, aTo :: Text, aToName :: Maybe Text, aFrom :: Text, +                         aFromName :: Text, aSubject :: Text, aBody :: Text, aHtml :: Bool } +             deriving (Show, Eq)++instance FromRow AmEmail where+  fromRow = AmEmail <$> field <*> field <*> field <*> field+                    <*> field <*> field <*> field <*> field+++runQueue :: Connection -> Manager -> IO ()+runQueue c m = do+  now <- getCurrentTime+  replicateM configLimit $ do+    -- NOTE(dbp 2013-12-12): This query has all the magic in it: it grabs an email+    -- off the queue, marks it as processing, and returns it. The nested query is to+    -- do the limiting, and the seeming redundant 'and processing = false' is b/c+    -- the inner query is in a separate transaction, so this could race (but the+    -- result would just be to have no message found even if one existed in database.+    email <- query_ c "update amazon_email_queue set processing = true where id = (select id from amazon_email_queue where sent_at is null and failed_count < 3 and processing = false order by date asc limit 1) and processing = false returning id, to_addr, to_name, from_addr, from_name, subject, body, html"+    sent <- EX.catch+            (sendEmails m email)+            (\e -> do putStrLn $ show (e::EX.SomeException)+                      execute c "update amazon_email_queue set failed_count = failed_count + 1, processing = false where id = ?" +                        (Only (aId $ head email))+                      return [])+    mapM (\i -> execute c "update amazon_email_queue set sent_at = ?, processing = false where id = ?" +                      (now, i))+            sent+    +  threadDelay 1000000 -- note, this is a conservative processing of the queue, as we don't include+                      -- the time that is spent actually sending the emails.+  runQueue c m++sendEmails :: Manager ->  [AmEmail] -> IO [Int]+sendEmails m es =+  forM es (\e -> do+            runResourceT (renderSendMailSES m (mkSES e) (mkMail e))+            return (aId e))++mkSES :: AmEmail -> SES+mkSES (AmEmail _ to _ from _ _ _ _) = SES (T.encodeUtf8 from) +                                        [T.encodeUtf8 to]+                                        configAccessKey+                                        configSecretKey++mkMail :: AmEmail -> Mail+mkMail (AmEmail _ to tname from fname subj body html) = +  Mail (Address (Just fname) from)+       [(Address tname to)]+       [] -- CC+       [] -- BCC+        [ ("Subject", subj) ]+       [[Part (if html then "text/html; charset=utf-8" else "text/plain; charset=utf-8")+         QuotedPrintableText Nothing []+         (LT.encodeUtf8 $ LT.fromStrict body)]]

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,32 @@+name:                amazon-emailer+version:             0.3.0.0+synopsis:            A queue daemon for working with Amazon's Simple Email Service with a+                     PostgreSQL table as a queue.+description:         This application checks every second for messages in a queue table,+                     if there exist some that haven't been sent, it grabs+                     a specified number out (based on what your current send rate is), sends them,+                     marks them as sent, and goes back to sleep.+homepage:            http://hub.darcs.net/dbp/amazon-emailer+license:             BSD3+license-file:        LICENSE+author:              Daniel Patterson+maintainer:          dbp@dbpmail.net+-- copyright:           +category:            Network+build-type:          Simple+cabal-version:       >=1.8++executable amazon-emailer+  main-is: Mailer.hs+  -- other-modules:       +  Build-depends:+        base == 4.*,+        resourcet == 0.4.*,+        lifted-base == 0.2.*,+        text == 0.11.*,+        bytestring >= 0.9.1 && < 0.11,+        postgresql-simple == 0.3.*,+        http-conduit == 2.*,+        mime-mail == 0.4.*,+        mime-mail-ses == 0.2.*,+        time >= 1.1 && < 1.5