From 7dd1b4cba8731da40b2df98fd0ec1e899fe5a9d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Oct 2010 10:19:06 +0200 Subject: [PATCH] Email authentication in scaffolded site --- Yesod.hs | 11 ++++ scaffold/cabal.cg | 1 + scaffold/sitearg_hs.cg | 123 +++++++++++++++++++++++------------------ 3 files changed, 82 insertions(+), 53 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index b1f16f4f8..948e1b01d 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -15,6 +15,8 @@ module Yesod , liftIO , MonadInvertIO , mempty + , showIntegral + , readIntegral ) where #if TEST @@ -40,3 +42,12 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Data.Monoid (mempty) import Control.Monad.Invert (MonadInvertIO) + +showIntegral :: Integral a => a -> String +showIntegral x = show (fromIntegral x :: Integer) + +readIntegral :: Num a => String -> Maybe a +readIntegral s = + case reads s of + (i, _):_ -> Just $ fromInteger i + [] -> Nothing diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 0cbf05fcc..c09e4b616 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -27,6 +27,7 @@ executable simple-server , wai-extra , directory , bytestring + , text , persistent , persistent-~lower~ , template-haskell diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 60b5a1fdf..59d87a707 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -17,6 +17,7 @@ import Yesod import Yesod.Helpers.Static import Yesod.Helpers.Auth import Yesod.Helpers.Auth.OpenId +import Yesod.Helpers.Auth.Email import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L @@ -24,6 +25,11 @@ import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile) import Model +import Data.Maybe (isJust) +import Control.Monad (join) +import Network.Mail.Mime +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Encoding -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -127,68 +133,79 @@ instance YesodAuth ~sitearg~ where Nothing -> do fmap Just $ insert $ User (credsIdent creds) Nothing - showAuthId _ x = show (fromIntegral x :: Integer) - readAuthId _ s = case reads s of - (i, _):_ -> Just $ fromInteger i - [] -> Nothing + showAuthId _ = showIntegral + readAuthId _ = readIntegral authPlugins = [ authOpenId + , authEmail ] -{- FIXME - emailSettings _ = Just EmailSettings - { addUnverified = \email verkey -> - runDB $ insert $ Email email Nothing (Just verkey) - , sendVerifyEmail = sendVerifyEmail' - , 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] - 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 YesodAuthEmail ~sitearg~ where + type AuthEmailId ~sitearg~ = EmailId + + showAuthEmailId _ = showIntegral + readAuthEmailId _ = readIntegral + + addUnverified email verkey = + runDB $ insert $ Email email Nothing $ Just verkey + sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail + { mailHeaders = + [ ("From", "noreply") + , ("To", email) + , ("Subject", "Verify your email address") + ] + , mailParts = [[textPart, htmlPart]] } - -sendVerifyEmail' :: String -> String -> String -> GHandler Auth m () -sendVerifyEmail' email _ verurl = - liftIO $ renderSendMail Mail - { mailHeaders = - [ ("From", "noreply") - , ("To", email) - , ("Subject", "Verify your email address") + where + textPart = Part + { partType = "text/plain; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = Data.Text.Lazy.Encoding.encodeUtf8 + $ Data.Text.Lazy.pack $ unlines + [ "Please confirm your email address by clicking on the link below." + , "" + , verurl + , "" + , "Thank you" ] - , mailPlain = verurl - , mailParts = return Part - { partType = "text/html; charset=utf-8" - , partEncoding = None - , partDisposition = Inline - , partContent = renderHamlet id [$hamlet| + } + htmlPart = Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = renderHtml [$hamlet| %p Please confirm your email address by clicking on the link below. %p %a!href=$verurl$ $verurl$ %p Thank you -|~~] - } +|] } --} + 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