275 lines
8.5 KiB
Haskell
275 lines
8.5 KiB
Haskell
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
|
|
module Yesod.Helpers.EmailAuth
|
|
( getEmailAuth
|
|
, EmailAuth
|
|
, siteEmailAuth
|
|
, EmailAuthRoutes (..)
|
|
, YesodEmailAuth (..)
|
|
) where
|
|
|
|
import Yesod
|
|
import Yesod.Helpers.Auth
|
|
import System.Random
|
|
import Data.Maybe
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.Digest.Pure.MD5
|
|
|
|
class Yesod y => YesodEmailAuth y where
|
|
addUnverified :: y
|
|
-> String -- ^ email
|
|
-> String -- ^ verification key
|
|
-> IO Integer -- ^ login_id
|
|
sendVerifyEmail :: y
|
|
-> String -- ^ email
|
|
-> String -- ^ verification key
|
|
-> String -- ^ verify URL
|
|
-> IO ()
|
|
getVerifyKey :: y
|
|
-> Integer -- ^ login_id
|
|
-> IO (Maybe String)
|
|
verifyAccount :: y
|
|
-> Integer -- ^ login_id
|
|
-> IO ()
|
|
setPassword :: y
|
|
-> Integer -- ^ login_id
|
|
-> String -- ^ salted password
|
|
-> IO ()
|
|
getCreds :: y
|
|
-> String -- ^ email address
|
|
-> IO (Maybe (Integer, Maybe String, Bool, String)) -- ^ id, salted pass, is verified, verify key
|
|
getEmail :: y -> Integer -> IO (Maybe String)
|
|
|
|
randomKey :: y -> IO String
|
|
randomKey _ = do
|
|
stdgen <- newStdGen
|
|
return $ take 10 $ randomRs ('A', 'Z') stdgen
|
|
|
|
onSuccessfulLogin :: y -> Routes y
|
|
onSuccessfulLogout :: y -> Routes y
|
|
|
|
onEmailAuthLogin :: y
|
|
-> String -- ^ email
|
|
-> Integer -- ^ login_id
|
|
-> IO ()
|
|
|
|
data EmailAuth = EmailAuth
|
|
|
|
getEmailAuth :: a -> EmailAuth
|
|
getEmailAuth _ = EmailAuth
|
|
|
|
mkYesodSub "EmailAuth" [''YesodEmailAuth] [$parseRoutes|
|
|
/register RegisterR GET POST
|
|
/verify/#/$ VerifyR GET
|
|
/login LoginR GET POST
|
|
/set-password PasswordR GET POST
|
|
/logout LogoutR GET
|
|
|]
|
|
|
|
getRegisterR :: Yesod master => GHandler EmailAuth master RepHtml
|
|
getRegisterR = do
|
|
toMaster <- getRouteToMaster
|
|
applyLayout "Register a new account" $ [$hamlet|
|
|
%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
|
|
%form!method=post!action=@RegisterR.toMaster@
|
|
%label!for=email E-mail
|
|
%input#email!type=email!name=email!width=150
|
|
%input!type=submit!value=Register
|
|
|] ()
|
|
|
|
postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml
|
|
postRegisterR = do
|
|
email <- runFormPost $ checkEmail $ required $ input "email"
|
|
y <- getYesodMaster
|
|
creds <- liftIO $ getCreds y email
|
|
(lid, verKey) <-
|
|
case creds of
|
|
Nothing -> liftIO $ do
|
|
key <- randomKey y
|
|
lid <- addUnverified y email key
|
|
return (lid, key)
|
|
Just (lid, _, _, key) -> return (lid, key)
|
|
render <- getUrlRender
|
|
let verUrl = render $ VerifyR lid verKey
|
|
liftIO $ sendVerifyEmail y email verKey verUrl
|
|
applyLayout "Confirmation e-mail sent" $ [$hamlet|
|
|
%p A confirmation e-mail has been sent to $email.cs$.
|
|
|] ()
|
|
|
|
checkEmail :: Form ParamValue -> Form ParamValue
|
|
checkEmail = notEmpty -- FIXME
|
|
|
|
getVerifyR :: YesodEmailAuth master
|
|
=> Integer -> String -> GHandler EmailAuth master RepHtml
|
|
getVerifyR lid key = do
|
|
y <- getYesodMaster
|
|
realKey <- liftIO $ getVerifyKey y lid
|
|
memail <- liftIO $ getEmail y lid
|
|
case (realKey == Just key, memail) of
|
|
(True, Just email) -> do
|
|
liftIO $ verifyAccount y lid
|
|
setLoginSession email lid
|
|
toMaster <- getRouteToMaster
|
|
redirect RedirectTemporary $ toMaster PasswordR
|
|
_ -> applyLayout "Invalid verification key" $ [$hamlet|
|
|
%p I'm sorry, but that was an invalid verification key.
|
|
|] ()
|
|
|
|
messageKey :: String
|
|
messageKey = "MESSAGE"
|
|
|
|
getMessage :: GHandler sub master (Maybe HtmlContent)
|
|
getMessage = do
|
|
s <- session
|
|
clearSession messageKey
|
|
return $ listToMaybe $ map (Encoded . cs) $ s messageKey
|
|
|
|
setMessage :: String -> GHandler sub master ()
|
|
setMessage = setSession messageKey . cs
|
|
|
|
getLoginR :: Yesod master => GHandler EmailAuth master RepHtml
|
|
getLoginR = do
|
|
toMaster <- getRouteToMaster
|
|
msg <- getMessage
|
|
applyLayout "Login" $ [$hamlet|
|
|
$maybe msg ms
|
|
%p.message $ms$
|
|
%p Please log in to your account.
|
|
%p
|
|
%a!href=@RegisterR.toMaster@ I don't have an account
|
|
%form!method=post!action=@LoginR.toMaster@
|
|
%table
|
|
%tr
|
|
%th E-mail
|
|
%td
|
|
%input!type=email!name=email
|
|
%tr
|
|
%th Password
|
|
%td
|
|
%input!type=password!name=password
|
|
%tr
|
|
%td!colspan=2
|
|
%input!type=submit!value=Login
|
|
|] ()
|
|
|
|
postLoginR :: YesodEmailAuth master => GHandler EmailAuth master ()
|
|
postLoginR = do
|
|
(email, pass) <- runFormPost $ (,)
|
|
<$> checkEmail (required $ input "email")
|
|
<*> required (input "password")
|
|
y <- getYesodMaster
|
|
creds <- liftIO $ getCreds y email
|
|
let mlid =
|
|
case creds of
|
|
Just (lid, Just realpass, True, _) ->
|
|
if isValidPass pass realpass then Just lid else Nothing
|
|
_ -> Nothing
|
|
case mlid of
|
|
Just lid -> do
|
|
setLoginSession email lid
|
|
redirect RedirectTemporary $ onSuccessfulLogin y
|
|
Nothing -> do
|
|
setMessage "Invalid email/password combination"
|
|
toMaster <- getRouteToMaster
|
|
redirect RedirectTemporary $ toMaster LoginR
|
|
|
|
getPasswordR :: Yesod master => GHandler EmailAuth master RepHtml
|
|
getPasswordR = do
|
|
l <- isJust <$> isLoggedIn
|
|
toMaster <- getRouteToMaster
|
|
unless l $ do
|
|
setMessage "You must be logged in to set a password"
|
|
redirect RedirectTemporary $ toMaster LoginR
|
|
msg <- getMessage
|
|
applyLayout "Set password" $ [$hamlet|
|
|
$maybe msg ms
|
|
%p.message $ms$
|
|
%h3 Set a new password
|
|
%form!method=post!action=@PasswordR.toMaster@
|
|
%table
|
|
%tr
|
|
%th New password
|
|
%td
|
|
%input!type=password!name=new
|
|
%tr
|
|
%th Confirm
|
|
%td
|
|
%input!type=password!name=confirm
|
|
%tr
|
|
%td!colspan=2
|
|
%input!type=submit!value=Submit
|
|
|] ()
|
|
|
|
postPasswordR :: YesodEmailAuth master => GHandler EmailAuth master ()
|
|
postPasswordR = do
|
|
(new, confirm) <- runFormPost $ (,)
|
|
<$> notEmpty (required $ input "new")
|
|
<*> notEmpty (required $ input "confirm")
|
|
toMaster <- getRouteToMaster
|
|
when (new /= confirm) $ do
|
|
setMessage "Passwords did not match, please try again"
|
|
redirect RedirectTemporary $ toMaster PasswordR
|
|
mlid <- isLoggedIn
|
|
lid <- case mlid of
|
|
Just lid -> return lid
|
|
Nothing -> do
|
|
setMessage "You must be logged in to set a password"
|
|
redirect RedirectTemporary $ toMaster LoginR
|
|
salted <- liftIO $ saltPass new
|
|
y <- getYesodMaster
|
|
liftIO $ setPassword y lid salted
|
|
setMessage "Password updated"
|
|
redirect RedirectTemporary $ toMaster LoginR
|
|
|
|
getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml
|
|
getLogoutR = do
|
|
clearSession identKey
|
|
clearSession displayNameKey
|
|
clearSession emailAuthIdKey
|
|
y <- getYesodMaster
|
|
redirect RedirectTemporary $ onSuccessfulLogout y
|
|
|
|
saltLength :: Int
|
|
saltLength = 5
|
|
|
|
isValidPass :: String -- ^ cleartext password
|
|
-> String -- ^ salted password
|
|
-> Bool
|
|
isValidPass clear salted =
|
|
let salt = take saltLength salted
|
|
in salted == saltPass' salt clear
|
|
|
|
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 -- FIXME better salting scheme?
|
|
saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass)
|
|
|
|
emailAuthIdKey :: String
|
|
emailAuthIdKey = "EMAIL_AUTH_ID"
|
|
|
|
setLoginSession :: YesodEmailAuth master
|
|
=> String -> Integer -> GHandler sub master ()
|
|
setLoginSession email lid = do
|
|
setSession identKey email
|
|
setSession displayNameKey email
|
|
setSession emailAuthIdKey $ show lid
|
|
y <- getYesodMaster
|
|
liftIO $ onEmailAuthLogin y email lid
|
|
|
|
isLoggedIn :: GHandler sub master (Maybe Integer)
|
|
isLoggedIn = do
|
|
s <- session
|
|
return $
|
|
if null (s identKey)
|
|
then Nothing
|
|
else listToMaybe (s emailAuthIdKey) >>= readMay
|
|
|
|
readMay :: String -> Maybe Integer
|
|
readMay s = case reads s of
|
|
[] -> Nothing
|
|
((i, _):_) -> Just i
|