Merged EmailAuth into Auth
This commit is contained in:
Michael Snoyman
parent
ad7a3330d5
commit
e062033942
@ -30,6 +30,8 @@ module Yesod.Helpers.Auth
|
||||
, Creds (..)
|
||||
, maybeCreds
|
||||
, requireCreds
|
||||
, AuthEmailSettings (..)
|
||||
, inMemoryEmailSettings
|
||||
) where
|
||||
|
||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||
@ -40,6 +42,11 @@ import Yesod
|
||||
import Control.Monad.Attempt
|
||||
import Data.Maybe
|
||||
import Control.Monad
|
||||
import System.Random
|
||||
import Data.Digest.Pure.MD5
|
||||
import Control.Applicative
|
||||
import Control.Concurrent.MVar
|
||||
import System.IO
|
||||
|
||||
class Yesod master => YesodAuth master where
|
||||
-- | Default destination on successful login or logout, if no other
|
||||
@ -56,20 +63,47 @@ class Yesod master => YesodAuth master where
|
||||
onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()
|
||||
onLogin _ _ = return ()
|
||||
|
||||
-- | Generate a random alphanumeric string.
|
||||
--
|
||||
-- This is used for verify string in email authentication.
|
||||
randomKey :: master -> IO String
|
||||
randomKey _ = do
|
||||
stdgen <- newStdGen
|
||||
return $ take 10 $ randomRs ('A', 'Z') stdgen
|
||||
|
||||
data Auth = Auth
|
||||
{ authIsOpenIdEnabled :: Bool
|
||||
, authRpxnowApiKey :: Maybe String
|
||||
, authEmailSettings :: Maybe AuthEmailSettings
|
||||
}
|
||||
|
||||
data AuthType = AuthOpenId | AuthRpxnow
|
||||
data AuthType = AuthOpenId | AuthRpxnow | AuthEmail
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
type Email = String
|
||||
type VerKey = String
|
||||
type VerUrl = String
|
||||
type EmailId = Integer
|
||||
type SaltedPass = String
|
||||
type VerStatus = Bool
|
||||
data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey
|
||||
data AuthEmailSettings = AuthEmailSettings
|
||||
{ addUnverified :: Email -> VerKey -> IO EmailId
|
||||
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO ()
|
||||
, getVerifyKey :: EmailId -> IO (Maybe VerKey)
|
||||
, verifyAccount :: EmailId -> IO ()
|
||||
, setPassword :: EmailId -> String -> IO ()
|
||||
, getEmailCreds :: Email -> IO (Maybe EmailCreds)
|
||||
, getEmail :: EmailId -> IO (Maybe Email)
|
||||
}
|
||||
|
||||
-- | User credentials
|
||||
data Creds = Creds
|
||||
{ credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.
|
||||
, credsAuthType :: AuthType -- ^ How the user was authenticated
|
||||
, credsEmail :: Maybe String -- ^ Verified e-mail address.
|
||||
, credsDisplayName :: Maybe String -- ^ Display name.
|
||||
, credsId :: Maybe Integer -- ^ Numeric ID, if used.
|
||||
}
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
@ -98,6 +132,11 @@ mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|
|
||||
/openid/forward OpenIdForward GET
|
||||
/openid/complete OpenIdComplete GET
|
||||
/login/rpxnow RpxnowR
|
||||
|
||||
/register EmailRegisterR GET POST
|
||||
/verify/#/$ EmailVerifyR GET
|
||||
/login EmailLoginR GET POST
|
||||
/set-password EmailPasswordR GET POST
|
||||
|]
|
||||
|
||||
testOpenId :: GHandler Auth master ()
|
||||
@ -153,7 +192,7 @@ getOpenIdComplete = do
|
||||
redirect RedirectTemporary $ toMaster OpenIdR
|
||||
let onSuccess (OpenId.Identifier ident) = do
|
||||
y <- getYesod
|
||||
setCreds (Creds ident AuthOpenId Nothing Nothing) []
|
||||
setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) []
|
||||
redirectUltDest RedirectTemporary $ defaultDest y
|
||||
attempt onFailure onSuccess res
|
||||
|
||||
@ -175,6 +214,7 @@ handleRpxnowR = do
|
||||
AuthRpxnow
|
||||
(lookup "verifiedEmail" extra)
|
||||
(getDisplayName extra)
|
||||
Nothing
|
||||
setCreds creds extra
|
||||
either (redirect RedirectTemporary) (redirectString RedirectTemporary) $
|
||||
case pp "dest" of
|
||||
@ -234,3 +274,205 @@ identKey = "IDENTIFIER"
|
||||
|
||||
displayNameKey :: String
|
||||
displayNameKey = "DISPLAY_NAME"
|
||||
|
||||
getAuthEmailSettings :: GHandler Auth master AuthEmailSettings
|
||||
getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings
|
||||
|
||||
getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml
|
||||
getEmailRegisterR = do
|
||||
_ae <- getAuthEmailSettings
|
||||
toMaster <- getRouteToMaster
|
||||
applyLayout "Register a new account" (return ()) [$hamlet|
|
||||
%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
|
||||
%form!method=post!action=@toMaster.EmailRegisterR@
|
||||
%label!for=email E-mail
|
||||
%input#email!type=email!name=email!width=150
|
||||
%input!type=submit!value=Register
|
||||
|]
|
||||
|
||||
postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
|
||||
postEmailRegisterR = do
|
||||
ae <- getAuthEmailSettings
|
||||
email <- runFormPost $ checkEmail $ required $ input "email"
|
||||
y <- getYesod
|
||||
mecreds <- liftIO $ getEmailCreds ae email
|
||||
(lid, verKey) <-
|
||||
case mecreds of
|
||||
Nothing -> liftIO $ do
|
||||
key <- randomKey y
|
||||
lid <- addUnverified ae email key
|
||||
return (lid, key)
|
||||
Just (EmailCreds lid _ _ key) -> return (lid, key)
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ EmailVerifyR lid verKey
|
||||
liftIO $ sendVerifyEmail ae email verKey verUrl
|
||||
applyLayout "Confirmation e-mail sent" (return ()) [$hamlet|
|
||||
%p A confirmation e-mail has been sent to $cs.email$.
|
||||
|]
|
||||
|
||||
checkEmail :: Form ParamValue -> Form ParamValue
|
||||
checkEmail = notEmpty -- FIXME
|
||||
|
||||
getEmailVerifyR :: YesodAuth master
|
||||
=> Integer -> String -> GHandler Auth master RepHtml
|
||||
getEmailVerifyR lid key = do
|
||||
ae <- getAuthEmailSettings
|
||||
realKey <- liftIO $ getVerifyKey ae lid
|
||||
memail <- liftIO $ getEmail ae lid
|
||||
case (realKey == Just key, memail) of
|
||||
(True, Just email) -> do
|
||||
liftIO $ verifyAccount ae lid
|
||||
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster EmailPasswordR
|
||||
_ -> applyLayout "Invalid verification key" (return ()) [$hamlet|
|
||||
%p I'm sorry, but that was an invalid verification key.
|
||||
|]
|
||||
|
||||
getEmailLoginR :: Yesod master => GHandler Auth master RepHtml
|
||||
getEmailLoginR = do
|
||||
_ae <- getAuthEmailSettings
|
||||
toMaster <- getRouteToMaster
|
||||
msg <- getMessage
|
||||
applyLayout "Login" (return ()) [$hamlet|
|
||||
$maybe msg ms
|
||||
%p.message $ms$
|
||||
%p Please log in to your account.
|
||||
%p
|
||||
%a!href=@toMaster.EmailRegisterR@ I don't have an account
|
||||
%form!method=post!action=@toMaster.EmailLoginR@
|
||||
%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
|
||||
|]
|
||||
|
||||
postEmailLoginR :: YesodAuth master => GHandler Auth master ()
|
||||
postEmailLoginR = do
|
||||
ae <- getAuthEmailSettings
|
||||
(email, pass) <- runFormPost $ (,)
|
||||
<$> checkEmail (required $ input "email")
|
||||
<*> required (input "password")
|
||||
y <- getYesod
|
||||
mecreds <- liftIO $ getEmailCreds ae email
|
||||
let mlid =
|
||||
case mecreds of
|
||||
Just (EmailCreds lid (Just realpass) True _) ->
|
||||
if isValidPass pass realpass then Just lid else Nothing
|
||||
_ -> Nothing
|
||||
case mlid of
|
||||
Just lid -> do
|
||||
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []
|
||||
redirectUltDest RedirectTemporary $ defaultDest y
|
||||
Nothing -> do
|
||||
setMessage $ cs "Invalid email/password combination"
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
|
||||
getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml
|
||||
getEmailPasswordR = do
|
||||
_ae <- getAuthEmailSettings
|
||||
toMaster <- getRouteToMaster
|
||||
mcreds <- maybeCreds
|
||||
case mcreds of
|
||||
Just (Creds _ AuthEmail _ _ (Just _)) -> return ()
|
||||
_ -> do
|
||||
setMessage $ cs "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
msg <- getMessage
|
||||
applyLayout "Set password" (return ()) [$hamlet|
|
||||
$maybe msg ms
|
||||
%p.message $ms$
|
||||
%h3 Set a new password
|
||||
%form!method=post!action=@toMaster.EmailPasswordR@
|
||||
%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
|
||||
|]
|
||||
|
||||
postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
|
||||
postEmailPasswordR = do
|
||||
ae <- getAuthEmailSettings
|
||||
(new, confirm) <- runFormPost $ (,)
|
||||
<$> notEmpty (required $ input "new")
|
||||
<*> notEmpty (required $ input "confirm")
|
||||
toMaster <- getRouteToMaster
|
||||
when (new /= confirm) $ do
|
||||
setMessage $ cs "Passwords did not match, please try again"
|
||||
redirect RedirectTemporary $ toMaster EmailPasswordR
|
||||
mcreds <- maybeCreds
|
||||
lid <- case mcreds of
|
||||
Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid
|
||||
_ -> do
|
||||
setMessage $ cs "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
salted <- liftIO $ saltPass new
|
||||
liftIO $ setPassword ae lid salted
|
||||
setMessage $ cs "Password updated"
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
|
||||
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)
|
||||
|
||||
inMemoryEmailSettings :: IO AuthEmailSettings
|
||||
inMemoryEmailSettings = do
|
||||
mm <- newMVar []
|
||||
return $ AuthEmailSettings
|
||||
{ addUnverified = \email verkey -> modifyMVar mm $ \m -> do
|
||||
let helper (_, EmailCreds x _ _ _) = x
|
||||
let newId = 1 + maximum (0 : map helper m)
|
||||
let ec = EmailCreds newId Nothing False verkey
|
||||
return ((email, ec) : m, newId)
|
||||
, sendVerifyEmail = \_email _verkey verurl ->
|
||||
hPutStrLn stderr $ "Please go to: " ++ verurl
|
||||
, getVerifyKey = \eid -> withMVar mm $ \m -> return $
|
||||
lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m
|
||||
, verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid)
|
||||
, setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass)
|
||||
, getEmailCreds = \email -> withMVar mm $ return . lookup email
|
||||
, getEmail = \eid -> withMVar mm $ \m -> return $
|
||||
case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of
|
||||
((email, _):_) -> Just email
|
||||
_ -> Nothing
|
||||
}
|
||||
where
|
||||
vago eid (email, EmailCreds eid' pass status key)
|
||||
| eid == eid' = (email, EmailCreds eid pass True key)
|
||||
| otherwise = (email, EmailCreds eid' pass status key)
|
||||
spgo eid pass (email, EmailCreds eid' pass' status key)
|
||||
| eid == eid' = (email, EmailCreds eid (Just pass) status key)
|
||||
| otherwise = (email, EmailCreds eid' pass' status key)
|
||||
|
||||
@ -1,263 +0,0 @@
|
||||
{-# 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" (return ()) [$hamlet|
|
||||
%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
|
||||
%form!method=post!action=@toMaster.RegisterR@
|
||||
%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 <- getYesod
|
||||
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
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ VerifyR lid verKey
|
||||
liftIO $ sendVerifyEmail y email verKey verUrl
|
||||
applyLayout "Confirmation e-mail sent" (return ()) [$hamlet|
|
||||
%p A confirmation e-mail has been sent to $cs.email$.
|
||||
|]
|
||||
|
||||
checkEmail :: Form ParamValue -> Form ParamValue
|
||||
checkEmail = notEmpty -- FIXME
|
||||
|
||||
getVerifyR :: YesodEmailAuth master
|
||||
=> Integer -> String -> GHandler EmailAuth master RepHtml
|
||||
getVerifyR lid key = do
|
||||
y <- getYesod
|
||||
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" (return ()) [$hamlet|
|
||||
%p I'm sorry, but that was an invalid verification key.
|
||||
|]
|
||||
|
||||
getLoginR :: Yesod master => GHandler EmailAuth master RepHtml
|
||||
getLoginR = do
|
||||
toMaster <- getRouteToMaster
|
||||
msg <- getMessage
|
||||
applyLayout "Login" (return ()) [$hamlet|
|
||||
$maybe msg ms
|
||||
%p.message $ms$
|
||||
%p Please log in to your account.
|
||||
%p
|
||||
%a!href=@toMaster.RegisterR@ I don't have an account
|
||||
%form!method=post!action=@toMaster.LoginR@
|
||||
%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 <- getYesod
|
||||
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 $ cs "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 $ cs "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
msg <- getMessage
|
||||
applyLayout "Set password" (return ()) [$hamlet|
|
||||
$maybe msg ms
|
||||
%p.message $ms$
|
||||
%h3 Set a new password
|
||||
%form!method=post!action=@toMaster.PasswordR@
|
||||
%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 $ cs "Passwords did not match, please try again"
|
||||
redirect RedirectTemporary $ toMaster PasswordR
|
||||
mlid <- isLoggedIn
|
||||
lid <- case mlid of
|
||||
Just lid -> return lid
|
||||
Nothing -> do
|
||||
setMessage $ cs "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
salted <- liftIO $ saltPass new
|
||||
y <- getYesod
|
||||
liftIO $ setPassword y lid salted
|
||||
setMessage $ cs "Password updated"
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
|
||||
getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml
|
||||
getLogoutR = do
|
||||
clearSession identKey
|
||||
clearSession displayNameKey
|
||||
clearSession emailAuthIdKey
|
||||
y <- getYesod
|
||||
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 <- getYesod
|
||||
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
|
||||
@ -50,7 +50,6 @@ library
|
||||
Yesod.Helpers.Auth
|
||||
Yesod.Helpers.Sitemap
|
||||
Yesod.Helpers.Static
|
||||
Yesod.Helpers.EmailAuth
|
||||
Web.Mime
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user