Remove YesodAuthEmail from scaffolding
This commit is contained in:
parent
05ca4bc907
commit
6a949e7f29
@ -22,7 +22,6 @@ import Yesod.Static (Static, base64md5, StaticRoute(..))
|
|||||||
import Settings.StaticFiles
|
import Settings.StaticFiles
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import Yesod.Auth.OpenId
|
import Yesod.Auth.OpenId
|
||||||
import Yesod.Auth.Email
|
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Yesod.Logger (Logger, logLazyText)
|
import Yesod.Logger (Logger, logLazyText)
|
||||||
@ -31,15 +30,12 @@ import qualified Data.ByteString.Lazy as L
|
|||||||
import Database.Persist.~importGenericDB~
|
import Database.Persist.~importGenericDB~
|
||||||
import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
|
import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
|
||||||
import Model
|
import Model
|
||||||
import Data.Maybe (isJust)
|
|
||||||
import Control.Monad (join)
|
|
||||||
import Network.Mail.Mime
|
|
||||||
import qualified Data.Text.Lazy.Encoding
|
import qualified Data.Text.Lazy.Encoding
|
||||||
import Text.Jasmine (minifym)
|
import Text.Jasmine (minifym)
|
||||||
import Web.ClientSession (getKey)
|
import Web.ClientSession (getKey)
|
||||||
import Text.Blaze.Renderer.Utf8 (renderHtml)
|
#if PRODUCTION
|
||||||
import Text.Hamlet (shamlet)
|
import Network.Mail.Mime (sendmail)
|
||||||
import Text.Shakespeare.Text (stext)
|
#endif
|
||||||
|
|
||||||
-- | The site argument for your application. This can be a good place to
|
-- | The site argument for your application. This can be a good place to
|
||||||
-- keep settings and values requiring initialization before your application
|
-- keep settings and values requiring initialization before your application
|
||||||
@ -131,9 +127,8 @@ instance YesodAuth ~sitearg~ where
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||||
|
|
||||||
authPlugins = [ authOpenId
|
-- You can add other plugins like BrowserID, email or OAuth here
|
||||||
, authEmail
|
authPlugins = [authOpenId]
|
||||||
]
|
|
||||||
|
|
||||||
-- Sends off your mail. Requires sendmail in production!
|
-- Sends off your mail. Requires sendmail in production!
|
||||||
deliver :: ~sitearg~ -> L.ByteString -> IO ()
|
deliver :: ~sitearg~ -> L.ByteString -> IO ()
|
||||||
@ -143,76 +138,7 @@ deliver _ = sendmail
|
|||||||
deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8
|
deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
instance YesodAuthEmail ~sitearg~ where
|
-- This instance is required to use forms. You can modify renderMessage to
|
||||||
type AuthEmailId ~sitearg~ = EmailId
|
-- achieve customized and internationalized form validation messages.
|
||||||
|
|
||||||
addUnverified email verkey =
|
|
||||||
runDB $ insert $ Email email Nothing $ Just verkey
|
|
||||||
|
|
||||||
sendVerifyEmail email _ verurl = do
|
|
||||||
y <- getYesod
|
|
||||||
liftIO $ deliver y =<< renderMail' Mail
|
|
||||||
{
|
|
||||||
mailHeaders =
|
|
||||||
[ ("From", "noreply")
|
|
||||||
, ("To", email)
|
|
||||||
, ("Subject", "Verify your email address")
|
|
||||||
]
|
|
||||||
, mailParts = [[textPart, htmlPart]]
|
|
||||||
}
|
|
||||||
where
|
|
||||||
textPart = Part
|
|
||||||
{ partType = "text/plain; charset=utf-8"
|
|
||||||
, partEncoding = None
|
|
||||||
, partFilename = Nothing
|
|
||||||
, partContent = Data.Text.Lazy.Encoding.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 [~qq~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 emailVerkey) . get
|
|
||||||
setVerifyKey eid key = runDB $ update eid [EmailVerkey =. Just key]
|
|
||||||
verifyAccount eid = runDB $ do
|
|
||||||
me <- get eid
|
|
||||||
case me of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just e -> do
|
|
||||||
let email = emailEmail e
|
|
||||||
case emailUser e of
|
|
||||||
Just uid -> return $ Just uid
|
|
||||||
Nothing -> do
|
|
||||||
uid <- insert $ User email Nothing
|
|
||||||
update eid [EmailUser =. Just uid, EmailVerkey =. Nothing]
|
|
||||||
return $ Just uid
|
|
||||||
getPassword = runDB . fmap (join . fmap userPassword) . get
|
|
||||||
setPassword uid pass = runDB $ update uid [UserPassword =. Just pass]
|
|
||||||
getEmailCreds email = runDB $ do
|
|
||||||
me <- getBy $ UniqueEmail email
|
|
||||||
case me of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just (eid, e) -> return $ Just EmailCreds
|
|
||||||
{ emailCredsId = eid
|
|
||||||
, emailCredsAuthId = emailUser e
|
|
||||||
, emailCredsStatus = isJust $ emailUser e
|
|
||||||
, emailCredsVerkey = emailVerkey e
|
|
||||||
}
|
|
||||||
getEmail = runDB . fmap (fmap emailEmail) . get
|
|
||||||
|
|
||||||
instance RenderMessage ~sitearg~ FormMessage where
|
instance RenderMessage ~sitearg~ FormMessage where
|
||||||
renderMessage _ _ = defaultFormMessage
|
renderMessage _ _ = defaultFormMessage
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user