diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2014, David Johnson + +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 Michael Snoyman 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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/ses-html-snaplet.cabal b/ses-html-snaplet.cabal new file mode 100644 --- /dev/null +++ b/ses-html-snaplet.cabal @@ -0,0 +1,29 @@ +name: ses-html-snaplet +version: 0.1.0.0 +synopsis: Snaplet for the ses-html package +description: Send HTML formatted emails using Amazon's SES REST API with blaze +license: BSD3 +license-file: LICENSE +author: David Johnson +maintainer: djohnson.m@gmail.com +copyright: David Johnson +category: Web, AWS, Email, Snap, Network +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Snap.Snaplet.SES + hs-source-dirs: src + build-depends: base >=4.7 && <4.8 + , blaze-html >= 0.7.0.2 + , bytestring >= 0.10.4.0 + , configurator >= 0.3.0.0 + , ses-html >= 0.2.0.1 + , snap + , text + , transformers + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/dmjio/ses-html-snaplet diff --git a/src/Snap/Snaplet/SES.hs b/src/Snap/Snaplet/SES.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/SES.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Snap.Snaplet.SES + ( -- * Initialization + initAWSKeys + , sendEmail + , sendEmailBlaze + , withKeys + -- * Types + , AWSKeys (..) + , HasAWSKeys (..) + -- * Module Re-export + , module Network.SES + ) where + +import Control.Monad.Trans.Reader (ReaderT, asks, ask) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Configurator as C +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network.SES hiding (sendEmail, sendEmailBlaze) +import qualified Network.SES as SES +import Snap +import qualified Text.Blaze.Html5 as H + +------------------------------------------------------------------------------ +-- | Type to hold AWS Config Information +data AWSKeys = AWSKeys + { publicKey :: PublicKey -- ^ AWS Public Key + , secretKey :: SecretKey -- ^ AWS Secret Key + , region :: Region -- ^ AWS Region Key + , sender :: Text -- ^ AWS Verified Sender Email + } deriving Show + +------------------------------------------------------------------------------ +-- | Class to allow extraction of `AWSKeys` from arbitrary Monads constrained by MonadIO +class MonadIO m => HasAWSKeys m where + getKeys :: m AWSKeys + +instance HasAWSKeys (Handler b AWSKeys) where + getKeys = get + +instance MonadIO m => HasAWSKeys (ReaderT (Snaplet AWSKeys) m) where + getKeys = asks (^# snapletValue) + +instance MonadIO m => HasAWSKeys (ReaderT AWSKeys m) where + getKeys = ask + +------------------------------------------------------------------------------ +-- | Helper function for operating on `AWSKeys` inside of `HasAWSKeys` constrained Monads +withKeys + :: HasAWSKeys m + => (AWSKeys -> IO a) -- ^ Function operating on Keys + -> m a +withKeys f = getKeys >>= liftIO . f + +------------------------------------------------------------------------------ +-- | Send Blaze email from a snap handler +sendEmailBlaze + :: HasAWSKeys m + => To -- ^ Who the email is intended for + -> Subject -- ^ Email `Subject` + -> H.Html -- ^ Email Body + -> m SESResult +sendEmailBlaze + to + subject + body = withKeys $ \(AWSKeys secret public region sender) -> + SES.sendEmailBlaze + secret + public + region + (BL8.fromStrict $ encodeUtf8 sender) + to + subject + body + +------------------------------------------------------------------------------ +-- | Send a ByteString of HTML from a Snap Handler +sendEmail + :: HasAWSKeys m + => To -- ^ Who the email is intended for + -> Subject -- ^ email `Subject` + -> BL8.ByteString -- ^ email Body + -> m SESResult +sendEmail + to + subject + body = withKeys $ \(AWSKeys secret public region sender) -> + SES.sendEmail + secret + public + region + (BL8.fromStrict $ encodeUtf8 sender) + to + subject + body + +------------------------------------------------------------------------------ +-- | Initialize snaplet +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE RecordWildCards #-} +-- > {-# LANGUAGE TemplateHaskell #-} +-- > module Main ( main ) where +-- > +-- > import Control.Lens +-- > import qualified Data.ByteString.Char8 as B8 +-- > import qualified Data.ByteString.Lazy.Char8 as BL8 +-- > import Snap +-- > import Snap.Snaplet.SES +-- > +-- > data App = App { +-- > _awsKeys :: Snaplet AWSKeys +-- > } +-- > +-- > makeLenses ''App +-- > +-- > initApp :: SnapletInit App App +-- > initApp = makeSnaplet "name" "description" Nothing $ do +-- > _awsKeys <- nestSnaplet "ses-html" awsKeys initAWSKeys +-- > addRoutes [("/", handleKeys)] +-- > return App {..} +-- > where +-- > handleKeys = method GET $ do +-- > with awsKeys $ withKeys $ liftIO . print +-- > result <- with awsKeys $ sendEmail ["david@solidtranslate.com"] "cookie-crisp" "

TEST

" +-- > liftIO $ print result +-- > writeBS "done" +-- > +-- > main :: IO () +-- > main = do (_, app, _) <- runSnaplet Nothing initApp +-- > httpServe config app +-- > where +-- > config = setAccessLog ConfigNoLog $ +-- > setErrorLog ConfigNoLog $ +-- > defaultConfig +-- +-- .\/snaplets\/ses-html\/devel.cfg +-- +-- > public = "publickey" +-- > secret = "secretkey" +-- > region = "us-east-1" +-- > sender = "sender@verifiedaddress.com" +-- +initAWSKeys :: SnapletInit a AWSKeys +initAWSKeys = makeSnaplet "ses-html" "Get your aws keys" Nothing $ do + config <- getSnapletUserConfig + liftIO $ AWSKeys <$> ((PublicKey . encodeUtf8) <$> getPublic config) + <*> ((SecretKey . encodeUtf8) <$> getSecret config) + <*> getRegion config + <*> getSender config + where + getRegion config = do + let f :: Text -> Region + f "us-east-1" = USEast1 + f "us-west-2" = USWest2 + f "eu-west-1" = EUWest1 + f _ = USEast1 + fromMaybe USEast1 <$> fmap f <$> C.lookup config "region" + + getPublic : getSecret : getSender : _ + = map getConfig [ "public" + , "secret" + , "sender" + ] + getConfig name config = fromMaybe mempty <$> C.lookup config name +