From 5ca0dd74688b8f5ddb226bf582090cb08401c64b Mon Sep 17 00:00:00 2001 From: Alex Kardos Date: Sat, 5 Dec 2015 20:21:38 -0700 Subject: [PATCH] Added an example with email auth and an ses mailer This should help beginners get started with email authentication and utilize Amazon SES for reliable mailing instead of sendmail because sendmail is inherently unreliable with consumer based IP addresses. Points of interest: * Pulls SES authentication details from config/secrets.yaml to keep the secrets out of the source code * Needs the from email address to be confirmed with Amazon SES --- demo/auth/config/secrets.yaml | 2 + demo/auth/email_auth_ses_mailer.hs | 208 +++++++++++++++++++++++++++++ 2 files changed, 210 insertions(+) create mode 100644 demo/auth/config/secrets.yaml create mode 100644 demo/auth/email_auth_ses_mailer.hs diff --git a/demo/auth/config/secrets.yaml b/demo/auth/config/secrets.yaml new file mode 100644 index 00000000..0c547ac8 --- /dev/null +++ b/demo/auth/config/secrets.yaml @@ -0,0 +1,2 @@ +accessKey: +secretKey: diff --git a/demo/auth/email_auth_ses_mailer.hs b/demo/auth/email_auth_ses_mailer.hs new file mode 100644 index 00000000..2c0774ad --- /dev/null +++ b/demo/auth/email_auth_ses_mailer.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad (join) +import Control.Monad.Logger (runNoLoggingT) +import Data.Maybe (isJust) +import Data.Yaml +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.Encoding as LTE +import Data.Typeable (Typeable) +import Database.Persist.Sqlite +import Database.Persist.TH +import Network.Mail.Mime +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import Text.Shakespeare.Text (stext) +import Yesod +import Yesod.Auth +import Yesod.Auth.Email +import Network.Mail.Mime.SES +import Data.ByteString.Char8 +import Control.Monad (mzero) +import Network.HTTP.Client.Conduit (Manager, newManager, HasHttpManager (getHttpManager)) +import System.Exit (exitWith, ExitCode( ExitFailure )) + +share [mkPersist sqlSettings { mpsGeneric = False }, mkMigrate "migrateAll"] [persistLowerCase| +User + email Text + password Text Maybe -- Password may not be set yet + verkey Text Maybe -- Used for resetting passwords + verified Bool + UniqueUser email + deriving Typeable +|] + +data App = App + { sqlBackend :: SqlBackend + , appHttpManager :: Manager + } + +instance HasHttpManager App where + getHttpManager = appHttpManager + +mkYesod "App" [parseRoutes| +/ HomeR GET +/auth AuthR Auth getAuth +|] + +instance Yesod App where + -- Emails will include links, so be sure to include an approot so that + -- the links are valid! + approot = ApprootStatic "http://localhost:3000" + +instance RenderMessage App FormMessage where + renderMessage _ _ = defaultFormMessage + +-- Set up Persistent +instance YesodPersist App where + type YesodPersistBackend App = SqlBackend + runDB f = do + App conn _ <- getYesod + runSqlConn f conn + +instance YesodAuth App where + type AuthId App = UserId + + loginDest _ = HomeR + logoutDest _ = HomeR + authPlugins _ = [authEmail] + + -- Need to find the UserId for the given email address. + getAuthId creds = runDB $ do + x <- insertBy $ User (credsIdent creds) Nothing Nothing False + return $ Just $ + case x of + Left (Entity userid _) -> userid -- newly added user + Right userid -> userid -- existing user + + authHttpManager = error "Email doesn't need an HTTP manager" + +instance YesodAuthPersist App + +-- Here's all of the email-specific code + +data SesKeys = SesKeys { accessKey :: !Text, secretKey :: !Text } + +instance FromJSON SesKeys where + parseJSON (Object v) = + SesKeys <$> v .: "accessKey" + <*> v .: "secretKey" + parseJSON _ = mzero + +instance YesodAuthEmail App where + type AuthEmailId App = UserId + + afterPasswordRoute _ = HomeR + + addUnverified email verkey = + runDB $ insert $ User email Nothing (Just verkey) False + + -- Send the verification email with your SES credentials located in config/secrets.yaml + -- NOTE: The email address you're sending from will have to be verified on SES + sendVerifyEmail email _ verurl = do + h <- getYesod + sesCreds <- liftIO $ getSESCredentials + + liftIO $ renderSendMailSES (getHttpManager h) sesCreds (emptyMail $ Address Nothing "noreply@example.com") + { mailTo = [Address Nothing email] + , mailHeaders = + [ ("Subject", "Verify your email address") + ] + , mailParts = [[textPart, htmlPart]] + } + where + getSESCredentials :: IO SES + getSESCredentials = do + key <- getsesAccessKey + return SES { + sesTo = [(TE.encodeUtf8 email)], + sesFrom = "noreply@example.com", + sesAccessKey = TE.encodeUtf8 $ accessKey key, + sesSecretKey = TE.encodeUtf8 $ secretKey key, + sesRegion = usWest2 } + getsesAccessKey :: IO SesKeys + getsesAccessKey = do + ymlConfig <- Data.ByteString.Char8.readFile "config/secrets.yaml" + + case decode ymlConfig of + Nothing -> do Data.ByteString.Char8.putStrLn "Error while parsing secrets.yaml"; System.Exit.exitWith (ExitFailure 1) + Just c -> return c + + textPart = Part + { partType = "text/plain; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = LTE.encodeUtf8 $ + [stext| + Please confirm your email address by clicking on the link below. + + #{verurl} + + Thank you + |] + , partHeaders = [] + } + htmlPart = Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = renderHtml + [shamlet| +

Please confirm your email address by clicking on the link below. +

+ #{verurl} +

Thank you + |] + , partHeaders = [] + } + getVerifyKey = runDB . fmap (join . fmap userVerkey) . get + setVerifyKey uid key = runDB $ update uid [UserVerkey =. Just key] + verifyAccount uid = runDB $ do + mu <- get uid + case mu of + Nothing -> return Nothing + Just u -> do + update uid [UserVerified =. True] + return $ Just uid + getPassword = runDB . fmap (join . fmap userPassword) . get + setPassword uid pass = runDB $ update uid [UserPassword =. Just pass] + getEmailCreds email = runDB $ do + mu <- getBy $ UniqueUser email + case mu of + Nothing -> return Nothing + Just (Entity uid u) -> return $ Just EmailCreds + { emailCredsId = uid + , emailCredsAuthId = Just uid + , emailCredsStatus = isJust $ userPassword u + , emailCredsVerkey = userVerkey u + , emailCredsEmail = email + } + getEmail = runDB . fmap (fmap userEmail) . get + +getHomeR :: Handler Html +getHomeR = do + maid <- maybeAuthId + defaultLayout + [whamlet| +

Your current auth ID: #{show maid} + $maybe _ <- maid +

+ Logout + $nothing +

+ Go to the login page + |] + +main :: IO () +main = runNoLoggingT $ withSqliteConn "email.db3" $ \conn -> liftIO $ do + runSqlConn (runMigration migrateAll) conn + httpManager <- newManager + warp 3000 $ App conn httpManager