From e062033942e727766beb431e78e3506646aa245a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 11 May 2010 21:59:27 +0300 Subject: [PATCH] Merged EmailAuth into Auth --- Yesod/Helpers/Auth.hs | 246 +++++++++++++++++++++++++++++++++- Yesod/Helpers/EmailAuth.hs | 263 ------------------------------------- yesod.cabal | 1 - 3 files changed, 244 insertions(+), 266 deletions(-) delete mode 100644 Yesod/Helpers/EmailAuth.hs diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d7a2888c..326038fb 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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) diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs deleted file mode 100644 index d0ec8825..00000000 --- a/Yesod/Helpers/EmailAuth.hs +++ /dev/null @@ -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 diff --git a/yesod.cabal b/yesod.cabal index eae3bc17..28170733 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -50,7 +50,6 @@ library Yesod.Helpers.Auth Yesod.Helpers.Sitemap Yesod.Helpers.Static - Yesod.Helpers.EmailAuth Web.Mime ghc-options: -Wall