Email authentication in scaffolded site

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

scaffold/cabal.cg

@@ -27,6 +27,7 @@ executable         simple-server
                  , wai-extra
                  , directory
                  , bytestring
+                 , text
                  , persistent
                  , persistent-~lower~
                  , template-haskell

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)
+    showAuthId _ = showIntegral
-    readAuthId _ s = case reads s of
+    readAuthId _ = readIntegral
-                        (i, _):_ -> Just $ fromInteger i
-                        [] -> Nothing
 
     authPlugins = [ authOpenId
+                  , authEmail
                   ]
 
-{- FIXME
+instance YesodAuthEmail ~sitearg~ where
-    emailSettings _ = Just EmailSettings
+    type AuthEmailId ~sitearg~ = EmailId
-        { 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
-        }
 
-sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
+    showAuthEmailId _ = showIntegral
-sendVerifyEmail' email _ verurl =
+    readAuthEmailId _ = readIntegral
-    liftIO $ renderSendMail Mail
+
-            { mailHeaders =
+    addUnverified email verkey =
-                [ ("From", "noreply")
+        runDB $ insert $ Email email Nothing $ Just verkey
-                , ("To", email)
+    sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail
-                , ("Subject", "Verify your email address")
+        { 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
+                          $ Data.Text.Lazy.pack $ unlines
+                [ "Please confirm your email address by clicking on the link below."
+                , ""
+                , verurl
+                , ""
+                , "Thank you"
                 ]
-            , mailPlain = verurl
+            }
-            , mailParts = return Part
+        htmlPart = Part
-                { partType = "text/html; charset=utf-8"
+            { partType = "text/html; charset=utf-8"
-                , partEncoding = None
+            , partEncoding = None
-                , partDisposition = Inline
+            , partFilename = Nothing
-                , partContent = renderHamlet id [$hamlet|
+            , 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