Merge pull request #1116 from lethjakman/auth_demo
Added an example with email auth and an ses mailer
This commit is contained in:
Greg Weber
commit
2ecfec1b9a
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 New Issue
Block a user