diff --git a/Foundation.hs b/Foundation.hs index bab47cb..7d9f153 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -4,12 +4,17 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool) import Import.NoFoundation import Text.Hamlet (hamletFile) import Yesod.Auth.BrowserId (authBrowserId) +import Yesod.Auth.HashDB (HashDBUser(..),authHashDB) import Yesod.Auth.Message (AuthMessage (InvalidLogin)) import qualified Yesod.Core.Unsafe as Unsafe import Yesod.Core.Types (Logger) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Fay +instance HashDBUser User where + userPasswordHash = userPassword + setPasswordHash h u = u { userPassword = Just h } + -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have @@ -195,7 +200,8 @@ instance YesodAuth App where } -- You can add other plugins like BrowserID, email or OAuth here - authPlugins _ = [authBrowserId def] + authPlugins _ = [authBrowserId def, + authHashDB (Just . UniqueUser)] authHttpManager = getHttpManager diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index 43aa4c9..062d712 100644 --- a/Handler/YourAccount.hs +++ b/Handler/YourAccount.hs @@ -8,6 +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) getYourAccountR :: Handler Html getYourAccountR = do @@ -26,17 +28,18 @@ postYourAccountR = do let accountData = case result of FormSuccess res -> Just res _ -> Nothing - Just (name, localId, sshPubKey, avatarFile) = accountData + Just (name, localId, mPassword, sshPubKey, avatarFile) = accountData userId <- requireAuthId - updateUserAccount userId name localId sshPubKey avatarFile + updateUserAccount userId name localId mPassword sshPubKey avatarFile defaultLayout $ do setTitle "Your account" $(widgetFile "your-account") -yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Maybe Text, Maybe FileInfo) -yourAccountForm maybeName maybeLocalId maybeSshPubKey = renderBootstrap3 BootstrapBasicForm $ (,,,) +yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe FileInfo) +yourAccountForm maybeName maybeLocalId maybeSshPubKey = renderBootstrap3 BootstrapBasicForm $ (,,,,) <$> aopt textField (bfs MsgAccountName) (Just maybeName) <*> aopt textField (bfs MsgId) (Just maybeLocalId) + <*> aopt passwordConfirmField (bfs MsgPassword) Nothing <*> aopt textField (bfs MsgSshPubKey) (Just maybeSshPubKey) <*> fileAFormOpt (bfs MsgAvatar) @@ -54,12 +57,18 @@ isLocalIdAcceptable :: Text -> Bool isLocalIdAcceptable localId = match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds) -updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe FileInfo -> Handler () -updateUserAccount userId name maybeLocalId maybeSshPubKey maybeAvatarFile = do +updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe FileInfo -> Handler () +updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAvatarFile = do updateJustName userId name updateAvatar userId maybeAvatarFile 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)] updateAvatar :: Key User -> Maybe FileInfo -> Handler () updateAvatar _ Nothing = return () @@ -114,3 +123,21 @@ 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 eResult isReq -> + [whamlet| + +
confirm: + + |] + , fieldEnctype = UrlEncoded + } diff --git a/gonito.cabal b/gonito.cabal index 50b97c6..9b471cd 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -127,6 +127,8 @@ library , conduit-extra , resourcet , yesod-newsfeed + , yesod-auth-hashdb + , pwstore-fast executable gonito if flag(library-only) diff --git a/messages/en.msg b/messages/en.msg index 6ec026a..47c0f00 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -25,3 +25,4 @@ CommentText: Write a comment Send: Send Avatar: avatar About: about +Password: password diff --git a/templates/your-account.hamlet b/templates/your-account.hamlet index 7247125..24caeeb 100644 --- a/templates/your-account.hamlet +++ b/templates/your-account.hamlet @@ -11,6 +11,7 @@