create/verify password reset links

Application.hs

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

Foundation.hs

@@ -58,6 +58,13 @@ isTrustedAuthorized = do
       | isTrusted user -> return Authorized
       | 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 =
@@ -124,6 +131,9 @@ instance Yesod App where
 
     isAuthorized (AvatarR _) _ = return Authorized
 
+    isAuthorized CreateResetLinkR _ = isAdmin
+    isAuthorized (ResetPasswordR _) _ = return Authorized
+
     -- Default to Authorized for now.
     isAuthorized _ _ = isTrustedAuthorized
 
@@ -196,6 +206,8 @@ instance YesodAuth App where
                     , userLocalId = Nothing
                     , userIsAnonymous = False
                     , userAvatar = Nothing
+                    , userVerificationKey = Nothing
+                    , userKeyExpirationDate = Nothing
                     }
 
     -- You can add other plugins like BrowserID, email or OAuth here

Handler/AccountReset.hs

@@ -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

Handler/Common.hs

@@ -4,6 +4,10 @@ module Handler.Common where
 import Data.FileEmbed (embedFile)
 import Import
 
+import Crypto.PasswordStore
+import Yesod.Auth.HashDB (defaultStrength)
+
+
 -- These handlers embed files in the executable at compile time to avoid a
 -- runtime dependency, and for efficiency.
 
@@ -14,3 +18,29 @@ getFaviconR = return $ TypedContent "image/x-icon"
 getRobotsR :: Handler TypedContent
 getRobotsR = return $ TypedContent typePlain
                     $ 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)

Handler/ShowChallenge.hs

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

Handler/YourAccount.hs

@@ -8,8 +8,8 @@ import Text.Regex.TDFA
 import Data.Conduit.Binary
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
-import Crypto.PasswordStore
-import Yesod.Auth.HashDB (defaultStrength)
+
+import Handler.Common (passwordConfirmField, updatePassword)
 
 getYourAccountR :: Handler Html
 getYourAccountR = do
@@ -69,13 +69,6 @@ updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAva
   updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey
   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 _ Nothing = return ()
 updateAvatar userId (Just avatarFile) = do
@@ -129,21 +122,3 @@ getAvatarR userId = do
        sendResponse (typePng, toContent avatarBytes)
      Nothing -> do
        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
-    }

config/models

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

config/routes

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

gonito.cabal

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

messages/en.msg

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

templates/create-reset-link.hamlet

@@ -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>

templates/default-layout.hamlet

@@ -7,9 +7,10 @@
 
                 <li><a href="@{HomeR}">_{MsgHome}</a>
                 <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
+                <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
                 $if userIsAdmin $ entityVal user
                     <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">
             <li class="dropdown">

templates/password-reset-failed.hamlet

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

templates/password-reset.hamlet

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

templates/reset-link-created.hamlet

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

templates/reset-password.hamlet

@@ -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}.