summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDanielPatterson <>2014-02-07 04:25:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-07 04:25:00 (GMT)
commit333a226264e5cc914a9635cfa1b61c055f4973a7 (patch)
tree61794ecd54d62b9e4e23542d420d6a82de7a7577
version 0.3.0.00.3.0.0
-rw-r--r--LICENSE30
-rw-r--r--Mailer.hs89
-rw-r--r--Setup.hs2
-rw-r--r--amazon-emailer.cabal32
4 files changed, 153 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..afc9959
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Mailer.hs b/Mailer.hs
new file mode 100644
index 0000000..91fd517
--- /dev/null
+++ b/Mailer.hs
@@ -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)]]
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/amazon-emailer.cabal b/amazon-emailer.cabal
new file mode 100644
index 0000000..b253a66
--- /dev/null
+++ b/amazon-emailer.cabal
@@ -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 \ No newline at end of file