module Yesod.Helpers.Auth.Email
( authEmail
, YesodAuthEmail (..)
, EmailCreds (..)
, saltPass
) where
import Network.Mail.Mime (randomString)
import Yesod.Helpers.Auth
import System.Random
import Control.Monad (when)
import Control.Applicative ((<$>), (<*>))
import Data.Digest.Pure.MD5
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (encodeUtf8)
import Yesod.Form
import Yesod.Handler
import Yesod.Content
import Yesod.Widget
import Yesod.Core
import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
login, register, setpass :: AuthRoute
login = PluginR "email" ["login"]
register = PluginR "email" ["register"]
setpass = PluginR "email" ["set-password"]
verify :: String -> String -> AuthRoute
verify eid verkey = PluginR "email" ["verify", eid, verkey]
type Email = String
type VerKey = String
type VerUrl = String
type SaltedPass = String
type VerStatus = Bool
data EmailCreds m = EmailCreds
{ emailCredsId :: AuthEmailId m
, emailCredsAuthId :: Maybe (AuthId m)
, emailCredsStatus :: VerStatus
, emailCredsVerkey :: Maybe VerKey
}
class YesodAuth m => YesodAuthEmail m where
type AuthEmailId m
showAuthEmailId :: m -> AuthEmailId m -> String
readAuthEmailId :: m -> String -> Maybe (AuthEmailId m)
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)
setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()
verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))
getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)
setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()
getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))
getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
randomKey :: m -> IO String
randomKey _ = do
stdgen <- newStdGen
return $ fst $ randomString 10 stdgen
authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail =
AuthPlugin "email" dispatch $ \tm -> do
y <- lift getYesod
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
<form method="post" action="@{tm login}">
<table>
<tr>
<th>#{messageEmail y}
<td>
<input type="email" name="email">
<tr>
<th>#{messagePassword y}
<td>
<input type="password" name="password">
<tr>
<td colspan="2">
<input type="submit" value="Login via email">
<a href="@{tm register}">I don't have an account
|]
where
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
dispatch "GET" ["verify", eid, verkey] = do
y <- getYesod
case readAuthEmailId y eid of
Nothing -> notFound
Just eid' -> getVerifyR eid' verkey >>= sendResponse
dispatch "POST" ["login"] = postLoginR >>= sendResponse
dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse
dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
dispatch _ _ = notFound
getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
getRegisterR = do
y <- getYesod
toMaster <- getRouteToMaster
defaultLayout $ do
setTitle $ messageRegisterLong y
addHamlet
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
<p>#{messageEnterEmail y}
<form method="post" action="@{toMaster register}">
<label for="email">#{messageEmail y}
<input type="email" name="email" width="150">
<input type="submit" value="#{messageRegister y}">
|]
postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
postRegisterR = do
y <- getYesod
email <- runFormPost' $ emailInput "email"
mecreds <- getEmailCreds email
(lid, verKey) <-
case mecreds of
Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
Just (EmailCreds lid _ _ Nothing) -> do
key <- liftIO $ randomKey y
setVerifyKey lid key
return (lid, key)
Nothing -> do
key <- liftIO $ randomKey y
lid <- addUnverified email key
return (lid, key)
render <- getUrlRender
tm <- getRouteToMaster
let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey
sendVerifyEmail email verKey verUrl
defaultLayout $ do
setTitle $ messageConfirmationEmailSentTitle y
addWidget
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
<p>#{messageConfirmationEmailSent y email}
|]
getVerifyR :: YesodAuthEmail m
=> AuthEmailId m -> String -> GHandler Auth m RepHtml
getVerifyR lid key = do
realKey <- getVerifyKey lid
memail <- getEmail lid
y <- getYesod
case (realKey == Just key, memail) of
(True, Just email) -> do
muid <- verifyAccount lid
case muid of
Nothing -> return ()
Just _uid -> do
setCreds False $ Creds "email" email [("verifiedEmail", email)]
toMaster <- getRouteToMaster
setMessage $ messageAddressVerified y
redirect RedirectTemporary $ toMaster setpass
_ -> return ()
defaultLayout $ do
setTitle $ messageInvalidKey y
addHtml
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
<p>#{messageInvalidKey y}
|]
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
postLoginR = do
(email, pass) <- runFormPost' $ (,)
<$> emailInput "email"
<*> stringInput "password"
mecreds <- getEmailCreds email
maid <-
case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
(Just aid, Just True) -> do
mrealpass <- getPassword aid
case mrealpass of
Nothing -> return Nothing
Just realpass -> return $
if isValidPass pass realpass
then Just aid
else Nothing
_ -> return Nothing
case maid of
Just _aid ->
setCreds True $ Creds "email" email [("verifiedEmail", email)]
Nothing -> do
y <- getYesod
setMessage $ messageInvalidEmailPass y
toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR
getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml
getPasswordR = do
toMaster <- getRouteToMaster
maid <- maybeAuthId
y <- getYesod
case maid of
Just _ -> return ()
Nothing -> do
setMessage $ messageBadSetPass y
redirect RedirectTemporary $ toMaster login
defaultLayout $ do
setTitle $ messageSetPassTitle y
addHamlet
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
<h3>#{messageSetPass y}
<form method="post" action="@{toMaster setpass}">
<table>
<tr>
<th>#{messageNewPass y}
<td>
<input type="password" name="new">
<tr>
<th>#{messageConfirmPass y}
<td>
<input type="password" name="confirm">
<tr>
<td colspan="2">
<input type="submit" value="#{messageSetPassTitle y}">
|]
postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
postPasswordR = do
(new, confirm) <- runFormPost' $ (,)
<$> stringInput "new"
<*> stringInput "confirm"
toMaster <- getRouteToMaster
y <- getYesod
when (new /= confirm) $ do
setMessage $ messagePassMismatch y
redirect RedirectTemporary $ toMaster setpass
maid <- maybeAuthId
aid <- case maid of
Nothing -> do
setMessage $ messageBadSetPass y
redirect RedirectTemporary $ toMaster login
Just aid -> return aid
salted <- liftIO $ saltPass new
setPassword aid salted
setMessage $ messagePassUpdated y
redirect RedirectTemporary $ loginDest y
saltLength :: Int
saltLength = 5
saltPass :: String -> IO String
saltPass pass = do
stdgen <- newStdGen
let salt = take saltLength $ randomRs ('A', 'Z') stdgen
return $ saltPass' salt pass
saltPass' :: String -> String -> String
saltPass' salt pass =
salt ++ show (md5 $ fromString $ salt ++ pass)
where
fromString = encodeUtf8 . T.pack
isValidPass :: String
-> SaltedPass
-> Bool
isValidPass clear salted =
let salt = take saltLength salted
in salted == saltPass' salt clear