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
This commit is contained in:
Alex Kardos
parent
de3818784a
commit
5ca0dd7468
2 changed files with 210 additions and 0 deletions
2
demo/auth/config/secrets.yaml
Normal file
2
demo/auth/config/secrets.yaml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
accessKey: <your access key>
|
||||
secretKey: <your secret key>
|
||||
208
demo/auth/email_auth_ses_mailer.hs
Normal file
208
demo/auth/email_auth_ses_mailer.hs
Normal file
|
|
@ -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|
|
||||
<p>Please confirm your email address by clicking on the link below.
|
||||
<p>
|
||||
<a href=#{verurl}>#{verurl}
|
||||
<p>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|
|
||||
<p>Your current auth ID: #{show maid}
|
||||
$maybe _ <- maid
|
||||
<p>
|
||||
<a href=@{AuthR LogoutR}>Logout
|
||||
$nothing
|
||||
<p>
|
||||
<a href=@{AuthR LoginR}>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
|
||||
Loading…
Reference in a new issue