create/verify password reset links

This commit is contained in:
Filip Gralinski 2017-02-18 10:26:02 +01:00
parent 53c3647aaf
commit 62fb3ce251
16 changed files with 190 additions and 30 deletions

View File

@ -47,6 +47,7 @@ import Handler.Query
import Handler.ShowChallenge import Handler.ShowChallenge
import Handler.Shared import Handler.Shared
import Handler.YourAccount import Handler.YourAccount
import Handler.AccountReset
import Handler.Presentation import Handler.Presentation
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half

View File

@ -58,6 +58,13 @@ isTrustedAuthorized = do
| isTrusted user -> return Authorized | isTrusted user -> return Authorized
| otherwise -> return $ Unauthorized "???" | otherwise -> return $ Unauthorized "???"
isAdmin = do
mauth <- maybeAuth
case mauth of
Nothing -> return AuthenticationRequired
Just (Entity _ user)
| userIsAdmin user -> return Authorized
| otherwise -> return $ Unauthorized "only permitted for the admin"
isTrusted :: User -> Bool isTrusted :: User -> Bool
isTrusted user = isTrusted user =
@ -124,6 +131,9 @@ instance Yesod App where
isAuthorized (AvatarR _) _ = return Authorized isAuthorized (AvatarR _) _ = return Authorized
isAuthorized CreateResetLinkR _ = isAdmin
isAuthorized (ResetPasswordR _) _ = return Authorized
-- Default to Authorized for now. -- Default to Authorized for now.
isAuthorized _ _ = isTrustedAuthorized isAuthorized _ _ = isTrustedAuthorized
@ -196,6 +206,8 @@ instance YesodAuth App where
, userLocalId = Nothing , userLocalId = Nothing
, userIsAnonymous = False , userIsAnonymous = False
, userAvatar = Nothing , userAvatar = Nothing
, userVerificationKey = Nothing
, userKeyExpirationDate = Nothing
} }
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here

118
Handler/AccountReset.hs Normal file
View File

@ -0,0 +1,118 @@
module Handler.AccountReset where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import qualified Crypto.Nonce as Nonce
import System.IO.Unsafe (unsafePerformIO)
import Data.Time.Clock (addUTCTime)
import Handler.Common (passwordConfirmField, updatePassword)
getCreateResetLinkR :: Handler Html
getCreateResetLinkR = do
(formWidget, formEnctype) <- generateFormPost createResetLinkForm
defaultLayout $ do
setTitle "Create a reset link"
$(widgetFile "create-reset-link")
postCreateResetLinkR :: Handler Html
postCreateResetLinkR = do
((result, _), _) <- runFormPost createResetLinkForm
let mEmail = case result of
FormSuccess email -> Just email
_ -> Nothing
doCreateResetLink mEmail
doCreateResetLink :: Maybe Text -> Handler Html
doCreateResetLink (Just email) = do
mUserEnt <- runDB $ getBy $ UniqueUser email
userId <- createOrUse mUserEnt email
key <- newVerifyKey
theNow <- liftIO getCurrentTime
let expirationMoment = addUTCTime (60*60*24) theNow
runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment]
defaultLayout $ do
setTitle "Creating a reset link"
$(widgetFile "reset-link-created")
doCreateResetLink Nothing = do
setMessage $ toHtml ("No e-mail given" :: Text)
getCreateResetLinkR
createOrUse :: Maybe (Entity User) -> Text -> Handler UserId
createOrUse (Just userEnt) _ = return $ entityKey userEnt
createOrUse Nothing email = do
setMessage $ toHtml ("Created new user " ++ email)
userId <- runDB $ insert $ User email Nothing Nothing False Nothing True Nothing Nothing Nothing
return userId
createResetLinkForm :: Form Text
createResetLinkForm = renderBootstrap3 BootstrapBasicForm
$ areq textField (bfs MsgEMail) Nothing
nonceGen :: Nonce.Generator
nonceGen = unsafePerformIO Nonce.new
{-# NOINLINE nonceGen #-}
-- | Randomly create a new verification key.
newVerifyKey :: MonadIO m => m Text
newVerifyKey = Nonce.nonce128urlT nonceGen
getResetPasswordR :: Text -> Handler Html
getResetPasswordR key = do
(formWidget, formEnctype) <- generateFormPost changePasswordForm
mUserId <- checkVerificationKey key
master <- getYesod
defaultLayout $ do
setTitle "Reset password"
$(widgetFile "reset-password")
postResetPasswordR :: Text -> Handler Html
postResetPasswordR key = do
((result, _), _) <- runFormPost changePasswordForm
mUserId <- checkVerificationKey key
let mPassword = case result of
FormSuccess password -> Just password
_ -> Nothing
doResetPassword key mUserId mPassword
doResetPassword :: Text -> Maybe (Key User) -> Maybe Text -> Handler Html
doResetPassword key _ Nothing = do
setMessage $ toHtml ("Password not given or does not match! Make sure you entered the same password" :: Text)
getResetPasswordR key
doResetPassword _ (Just userId) (Just password) = do
updatePassword userId (Just password)
runDB $ update userId removeVerificationKeyStatement
defaultLayout $ do
setTitle "Reset password"
$(widgetFile "password-reset")
doResetPassword key Nothing _ = do
runDB $ updateWhere [UserVerificationKey ==. Just key] removeVerificationKeyStatement
master <- getYesod
defaultLayout $ do
setTitle "Reset password"
$(widgetFile "password-reset-failed")
removeVerificationKeyStatement :: [Update User]
removeVerificationKeyStatement = [UserVerificationKey =. Nothing, UserKeyExpirationDate =. Nothing]
checkVerificationKey :: Text -> Handler (Maybe UserId)
checkVerificationKey key = do
theNow <- liftIO getCurrentTime
userEnts <- runDB $ selectList [UserVerificationKey ==. Just key, UserKeyExpirationDate >. Just theNow] []
return $ case userEnts of
[Entity k _] -> Just k
_ -> Nothing
changePasswordForm :: Form Text
changePasswordForm = renderBootstrap3 BootstrapBasicForm
$ areq passwordConfirmField (bfs MsgPassword) Nothing

View File

@ -4,6 +4,10 @@ module Handler.Common where
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import Import import Import
import Crypto.PasswordStore
import Yesod.Auth.HashDB (defaultStrength)
-- These handlers embed files in the executable at compile time to avoid a -- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency. -- runtime dependency, and for efficiency.
@ -14,3 +18,29 @@ getFaviconR = return $ TypedContent "image/x-icon"
getRobotsR :: Handler TypedContent getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "config/robots.txt") $ toContent $(embedFile "config/robots.txt")
passwordConfirmField :: Field Handler Text
passwordConfirmField = Field
{ fieldParse = \rawVals _fileVals ->
case rawVals of
[a, b]
| a == b -> return $ Right $ Just a
| otherwise -> return $ Left "Passwords don't match"
[] -> return $ Right Nothing
_ -> return $ Left "You must enter two values"
, fieldView = \idAttr nameAttr otherAttrs _ _ ->
[whamlet|
<input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
<div>confirm new password:
<input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>
|]
, fieldEnctype = UrlEncoded
}
updatePassword :: Key User -> Maybe Text -> Handler ()
updatePassword _ Nothing = return ()
updatePassword userId (Just password) = do
encodedPassword <- liftIO $ makePassword (encodeUtf8 password) defaultStrength
runDB $ update userId [UserPassword =. Just (decodeUtf8 encodedPassword)]
setMessage $ toHtml ("Password set!" :: Text)

View File

@ -13,7 +13,6 @@ import System.Directory (doesFileExist)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Yesod.Table as Table import qualified Yesod.Table as Table
import Yesod.Table (Table)
import Handler.Extract import Handler.Extract
import Handler.Shared import Handler.Shared
@ -22,7 +21,6 @@ import Handler.Tables
import GEval.Core import GEval.Core
import GEval.OptionsParser import GEval.OptionsParser
import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import PersistSHA1 import PersistSHA1

View File

@ -8,8 +8,8 @@ import Text.Regex.TDFA
import Data.Conduit.Binary import Data.Conduit.Binary
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Crypto.PasswordStore
import Yesod.Auth.HashDB (defaultStrength) import Handler.Common (passwordConfirmField, updatePassword)
getYourAccountR :: Handler Html getYourAccountR :: Handler Html
getYourAccountR = do getYourAccountR = do
@ -69,13 +69,6 @@ updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAva
updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey
updatePassword userId maybePassword updatePassword userId maybePassword
updatePassword :: Key User -> Maybe Text -> Handler ()
updatePassword _ Nothing = return ()
updatePassword userId (Just password) = do
encodedPassword <- liftIO $ makePassword (encodeUtf8 password) defaultStrength
runDB $ update userId [UserPassword =. Just (decodeUtf8 encodedPassword)]
setMessage $ toHtml ("Password set!" :: Text)
updateAvatar :: Key User -> Maybe FileInfo -> Handler () updateAvatar :: Key User -> Maybe FileInfo -> Handler ()
updateAvatar _ Nothing = return () updateAvatar _ Nothing = return ()
updateAvatar userId (Just avatarFile) = do updateAvatar userId (Just avatarFile) = do
@ -129,21 +122,3 @@ getAvatarR userId = do
sendResponse (typePng, toContent avatarBytes) sendResponse (typePng, toContent avatarBytes)
Nothing -> do Nothing -> do
sendFile typeSvg "static/images/male-avatar.svg" sendFile typeSvg "static/images/male-avatar.svg"
passwordConfirmField :: Field Handler Text
passwordConfirmField = Field
{ fieldParse = \rawVals _fileVals ->
case rawVals of
[a, b]
| a == b -> return $ Right $ Just a
| otherwise -> return $ Left "Passwords don't match"
[] -> return $ Right Nothing
_ -> return $ Left "You must enter two values"
, fieldView = \idAttr nameAttr otherAttrs _ _ ->
[whamlet|
<input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
<div>confirm new password:
<input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>
|]
, fieldEnctype = UrlEncoded
}

View File

@ -7,6 +7,8 @@ User
localId Text Maybe localId Text Maybe
isAnonymous Bool default=False isAnonymous Bool default=False
avatar ByteString Maybe avatar ByteString Maybe
verificationKey Text Maybe
keyExpirationDate UTCTime Maybe
deriving Typeable deriving Typeable
PublicKey PublicKey
user UserId user UserId

View File

@ -28,5 +28,7 @@
/account YourAccountR GET POST /account YourAccountR GET POST
/avatar/#UserId AvatarR GET /avatar/#UserId AvatarR GET
/create-reset-link CreateResetLinkR GET POST
/reset-password/#Text ResetPasswordR GET POST
/presentation/4real Presentation4RealR GET /presentation/4real Presentation4RealR GET

View File

@ -43,6 +43,7 @@ library
Handler.Query Handler.Query
Handler.Tables Handler.Tables
Handler.YourAccount Handler.YourAccount
Handler.AccountReset
Handler.Presentation Handler.Presentation
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
@ -129,6 +130,7 @@ library
, yesod-newsfeed , yesod-newsfeed
, yesod-auth-hashdb , yesod-auth-hashdb
, pwstore-fast , pwstore-fast
, nonce
executable gonito executable gonito
if flag(library-only) if flag(library-only)

View File

@ -26,3 +26,6 @@ Send: Send
Avatar: avatar Avatar: avatar
About: about About: about
Password: new password Password: new password
EMail: e-mail
CreateResetLink: create reset link
LinkWrongOrExpired: Link wrong or expired, please ask the site admin again

View File

@ -0,0 +1,6 @@
<h2>Create a link for account creation or password reset
<form method=post action=@{CreateResetLinkR}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>

View File

@ -7,9 +7,10 @@
<li><a href="@{HomeR}">_{MsgHome}</a> <li><a href="@{HomeR}">_{MsgHome}</a>
<li><a href="@{Presentation4RealR}">_{MsgAbout}</a> <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
<li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
$if userIsAdmin $ entityVal user $if userIsAdmin $ entityVal user
<li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a> <li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a>
<li><a href="@{ListChallengesR}">_{MsgListChallenges}</a> <li><a href="@{CreateResetLinkR}">_{MsgCreateResetLink}</a>
<ul class="nav navbar-nav navbar-right"> <ul class="nav navbar-nav navbar-right">
<li class="dropdown"> <li class="dropdown">

View File

@ -0,0 +1 @@
<h3>_{MsgLinkWrongOrExpired} #{contactEmailLabel master}.

View File

@ -0,0 +1 @@
<p>OK, the password has been changed.

View File

@ -0,0 +1 @@
<p>Reset link created: <a href=@{ResetPasswordR key}>@{ResetPasswordR key}</a>

View File

@ -0,0 +1,7 @@
$maybe _ <- mUserId
<form method=post action=@{ResetPasswordR key}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>
$nothing
<h3>_{MsgLinkWrongOrExpired} #{contactEmailLabel master}.