diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,15 @@ +# 1.4.0 + +* Add proper support for i18n: + * Moved messages into Yesod.Auth.Account.Message module + * Added renderAccountMessage function to YesodAuthAccount class, which defaults to + the english messages. + * resendVerifyEmailWidget, resetPasswordWidget, newAccountForm, resetPasswordForm, and + runAccountPersistDB had their context's updated with a constraint for + `YesodAuthAccount db master`, which shouldn't be a problem. + +* Use the nonce package for generating the keys sent in the verification and reset + password emails. The `nonce` package provides efficient and cryptographically secure + nonces. + +* Support yesod 1.4 and persistent 2.1 (also bump our version to 1.4 to match yesod) diff --git a/Yesod/Auth/Account.hs b/Yesod/Auth/Account.hs --- a/Yesod/Auth/Account.hs +++ b/Yesod/Auth/Account.hs @@ -31,6 +31,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- Only orphan instance is RenderMessage AccountMessage -- | An auth plugin for accounts. Each account consists of a username, email, and password. -- @@ -112,10 +114,10 @@ import Control.Applicative import Control.Monad.Reader hiding (lift) import Data.Char (isAlphaNum) -import System.Random (newStdGen, randoms) +import System.IO.Unsafe (unsafePerformIO) import qualified Crypto.PasswordStore as PS +import qualified Crypto.Nonce as Nonce import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.URL as B64 import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Database.Persist as P @@ -126,10 +128,13 @@ import Yesod.Persist hiding (get, replace, insertKey, Entity, entityVal) import qualified Yesod.Auth.Message as Msg +import Yesod.Auth.Account.Message + -- | Each user is uniquely identified by a username. type Username = T.Text --- | The account authentication plugin. Here is a complete example using persistent. +-- | The account authentication plugin. Here is a complete example using persistent 2.1 +-- and yesod 1.4. -- -- >{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} -- >{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-} @@ -179,7 +184,7 @@ -- > renderMessage _ _ = defaultFormMessage -- > -- >instance YesodPersist MyApp where --- > type YesodPersistBackend MyApp = SqlPersistT +-- > type YesodPersistBackend MyApp = SqlBackend -- > runDB action = do -- > MyApp pool <- getYesod -- > runSqlPool action pool @@ -192,7 +197,7 @@ -- > authPlugins _ = [accountPlugin] -- > authHttpManager _ = error "No manager needed" -- > onLogin = return () --- > maybeAuthId = lookupSession "_ID" +-- > maybeAuthId = lookupSession credsKey -- > -- >instance AccountSendEmail MyApp -- > @@ -212,9 +217,9 @@ -- >|] -- > -- >main :: IO () --- >main = withSqlitePool "test.db3" 10 $ \pool -> do --- > runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool --- > warp 3000 $ MyApp pool +-- >main = runStderrLoggingT $ withSqlitePool "test.db3" 10 $ \pool -> do +-- > runSqlPool (runMigration migrateAll) pool +-- > liftIO $ warp 3000 $ MyApp pool -- accountPlugin :: YesodAuthAccount db master => AuthPlugin master accountPlugin = AuthPlugin "account" dispatch loginWidget @@ -266,28 +271,6 @@ setPasswordR :: AuthRoute setPasswordR = PluginR "account" ["setpassword"] --- | TODO: move these into Yesod.Auth.Message -data AccountMsg = MsgUsername - | MsgForgotPassword - | MsgInvalidUsername - | MsgUsernameExists T.Text - | MsgResendVerifyEmail - | MsgResetPwdEmailSent - | MsgEmailVerified - | MsgEmailUnverified - -instance RenderMessage m AccountMsg where - renderMessage _ _ MsgUsername = "Username" - renderMessage _ _ MsgForgotPassword = "Forgot password?" - renderMessage _ _ MsgInvalidUsername = "Invalid username" - renderMessage _ _ (MsgUsernameExists u) = - T.concat ["The username ", u, " already exists. Please choose an alternate username."] - renderMessage _ _ MsgResendVerifyEmail = "Resend verification email" - renderMessage _ _ MsgResetPwdEmailSent = "A password reset email has been sent to your email address." - renderMessage _ _ MsgEmailVerified = "Your email has been verified." - renderMessage _ _ MsgEmailUnverified = "Your email has not yet been verified." - - --------------------------------------------------------------------------------------------------- -- | The data collected in the login form. @@ -303,8 +286,9 @@ -- posted to 'loginFormPostTargetR'. loginForm :: (MonadHandler m, YesodAuthAccount db master, HandlerSite m ~ master) => AForm m LoginData -loginForm = LoginData <$> areq (checkM checkValidUsername textField) userSettings Nothing - <*> areq passwordField pwdSettings Nothing +loginForm = + LoginData <$> areq (checkM checkValidUsername textField) userSettings Nothing + <*> areq passwordField pwdSettings Nothing where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing [] pwdSettings = FieldSettings (SomeMessage Msg.Password) Nothing (Just "password") Nothing [] @@ -327,8 +311,8 @@ postLoginR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) Html postLoginR = do - ((result, _), _) <- lift $ runFormPostNoToken $ renderDivs loginForm mr <- lift getMessageRender + ((result, _), _) <- lift $ runFormPostNoToken $ renderDivs loginForm muser <- case result of FormMissing -> invalidArgs ["Form is missing"] FormFailure msg -> return $ Left msg @@ -462,7 +446,7 @@ lift $ setMessageI Msg.InvalidKey redirect LoginR lift $ runAccountDB $ verifyAccount user - setMessageI MsgEmailVerified + lift $ setMessageI MsgEmailVerified lift $ setCreds True $ Creds "account" uname [] -- | A form to allow the user to request the email validation be resent. @@ -476,7 +460,7 @@ resendVerifyEmailForm u = areq hiddenField "" $ Just u -- | A default rendering of 'resendVerifyEmailForm' -resendVerifyEmailWidget :: RenderMessage master FormMessage => Username -> (Route Auth -> Route master) -> WidgetT master IO () +resendVerifyEmailWidget :: YesodAuthAccount db master => Username -> (Route Auth -> Route master) -> WidgetT master IO () resendVerifyEmailWidget u tm = do ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs $ resendVerifyEmailForm u [whamlet| @@ -534,7 +518,7 @@ -- | A form for the user to request that an email be sent to them to allow them to reset -- their password. This form contains a field for the username (plus the CSRF token). -- The form should be posted to 'resetPasswordR'. -resetPasswordForm :: (RenderMessage master FormMessage +resetPasswordForm :: (YesodAuthAccount db master , MonadHandler m , HandlerSite m ~ master ) => AForm m Username @@ -542,7 +526,7 @@ where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing [] -- | A default rendering of 'resetPasswordForm'. -resetPasswordWidget :: (YesodAuth master, RenderMessage master FormMessage) +resetPasswordWidget :: YesodAuthAccount db master => (Route Auth -> Route master) -> WidgetT master IO () resetPasswordWidget tm = do ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs resetPasswordForm @@ -569,7 +553,7 @@ redirect LoginR Right Nothing -> do - setMessageI MsgInvalidUsername + lift $ setMessageI MsgInvalidUsername redirect resetPasswordR Right (Just u) -> do key <- newVerifyKey @@ -577,7 +561,7 @@ render <- getUrlRender lift $ sendNewPasswordEmail (username u) (userEmail u) $ render $ newPasswordR (username u) key -- Don't display the email in the message since anybody can request the resend. - setMessageI MsgResetPwdEmailSent + lift $ setMessageI MsgResetPwdEmailSent redirect LoginR -- | The data for setting a new password. @@ -888,6 +872,15 @@ setTitleI Msg.SetPassTitle newPasswordWidget u tm + -- | Used for i18n of 'AccountMsg', defaults to 'defaultAccountMsg'. To support + -- multiple languages, you can implement this method using the various translations + -- from "Yesod.Auth.Account.Message". + renderAccountMessage :: master -> [T.Text] -> AccountMsg -> T.Text + renderAccountMessage _ _ = defaultAccountMsg + +instance YesodAuthAccount db master => RenderMessage master AccountMsg where + renderMessage = renderAccountMessage + -- | Salt and hash a password. hashPassword :: MonadIO m => T.Text -> m B.ByteString hashPassword pwd = liftIO $ PS.makePassword (TE.encodeUtf8 pwd) 12 @@ -898,12 +891,13 @@ -> Bool verifyPassword pwd = PS.verifyPassword (TE.encodeUtf8 pwd) +nonceGen :: Nonce.Generator +nonceGen = unsafePerformIO Nonce.new +{-# NOINLINE nonceGen #-} + -- | Randomly create a new verification key. newVerifyKey :: MonadIO m => m T.Text -newVerifyKey = do - g <- liftIO newStdGen - let bs = B.pack $ take 32 $ randoms g - return $ TE.decodeUtf8 $ B64.encode bs +newVerifyKey = Nonce.nonce128urlT nonceGen --------------------------------------------------------------------------------------------------- @@ -968,9 +962,16 @@ , P.PersistEntity user , PersistUserCredentials user , b ~ YesodPersistBackend master +#if MIN_VERSION_persistent(2,1,0) + , b ~ PersistEntityBackend user + , PersistUnique b +#else , PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend user , P.PersistUnique (b (HandlerT master IO)) , P.PersistQuery (b (HandlerT master IO)) +#endif + , YesodAuthAccount db master + , db ~ AccountPersistDB master user ) => AccountPersistDB master user a -> HandlerT master IO a runAccountPersistDB (AccountPersistDB m) = runReaderT m funcs diff --git a/Yesod/Auth/Account/Message.hs b/Yesod/Auth/Account/Message.hs new file mode 100644 --- /dev/null +++ b/Yesod/Auth/Account/Message.hs @@ -0,0 +1,54 @@ +{- Copyright (c) 2014 John Lenz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Auth.Account.Message( + AccountMsg(..) + , defaultAccountMsg + , englishAccountMsg +) where + +import qualified Data.Text as T + +-- | Messages specific to yesod-auth-account. We also use messages from "Yesod.Auth.Message". +data AccountMsg = MsgUsername + | MsgForgotPassword + | MsgInvalidUsername + | MsgUsernameExists T.Text + | MsgResendVerifyEmail + | MsgResetPwdEmailSent + | MsgEmailVerified + | MsgEmailUnverified + +-- | Defaults to 'englishAccountMsg' +defaultAccountMsg :: AccountMsg -> T.Text +defaultAccountMsg = englishAccountMsg + +englishAccountMsg :: AccountMsg -> T.Text +englishAccountMsg MsgUsername = "Username" +englishAccountMsg MsgForgotPassword = "Forgot password?" +englishAccountMsg MsgInvalidUsername = "Invalid username" +englishAccountMsg (MsgUsernameExists u) = + T.concat ["The username ", u, " already exists. Please choose an alternate username."] +englishAccountMsg MsgResendVerifyEmail = "Resend verification email" +englishAccountMsg MsgResetPwdEmailSent = "A password reset email has been sent to your email address." +englishAccountMsg MsgEmailVerified = "Your email has been verified." +englishAccountMsg MsgEmailUnverified = "Your email has not yet been verified." diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -46,7 +46,7 @@ renderMessage _ _ = defaultFormMessage instance YesodPersist MyApp where - type YesodPersistBackend MyApp = SqlPersistT + type YesodPersistBackend MyApp = SqlBackend runDB action = do MyApp pool <- getYesod runSqlPool action pool @@ -59,7 +59,7 @@ authPlugins _ = [accountPlugin] authHttpManager _ = error "No manager needed" onLogin = return () - maybeAuthId = lookupSession "_ID" + maybeAuthId = lookupSession credsKey instance AccountSendEmail MyApp @@ -79,6 +79,6 @@ |] main :: IO () -main = withSqlitePool "test.db3" 10 $ \pool -> do - runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool - warp 3000 $ MyApp pool +main = runStderrLoggingT $ withSqlitePool "test.db3" 10 $ \pool -> do + runSqlPool (runMigration migrateAll) pool + liftIO $ warp 3000 $ MyApp pool diff --git a/tests/BasicTests.hs b/tests/BasicTests.hs --- a/tests/BasicTests.hs +++ b/tests/BasicTests.hs @@ -1,9 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module BasicTests (basicSpecs) where import Yesod.Test import Foundation +redirectCode :: Int +#if MIN_VERSION_yesod_test(1,4,0) +redirectCode = 303 +#else +redirectCode = 302 +#endif + basicSpecs :: YesodSpec MyApp basicSpecs = ydescribe "Basic tests" $ do @@ -20,7 +27,7 @@ byLabel "Username" "abc" byLabel "Password" "xxx" - statusIs 302 + statusIs redirectCode get' "/auth/login" statusIs 200 bodyContains "Invalid username/password combination" @@ -40,21 +47,21 @@ byLabel "Username" "abc" addNonce - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "Invalid username" yit "verify page returns an error" $ do get' "/auth/page/account/verify/abc/xxxxxx" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "invalid verification key" yit "new password returns an error" $ do get' "/auth/page/account/newpassword/abc/xxxxxx" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "invalid verification key" @@ -67,7 +74,7 @@ addPostParam "f4" "xxx" addPostParam "f5" "xxx" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "As a protection against cross-site" diff --git a/tests/Foundation.hs b/tests/Foundation.hs --- a/tests/Foundation.hs +++ b/tests/Foundation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-} {-# LANGUAGE GADTs, MultiParamTypeClasses, TypeSynonymInstances #-} @@ -64,7 +64,11 @@ renderMessage _ _ = defaultFormMessage instance YesodPersist MyApp where +#if MIN_VERSION_yesod(1,4,0) + type YesodPersistBackend MyApp = SqlBackend +#else type YesodPersistBackend MyApp = SqlPersistT +#endif runDB action = do MyApp pool <- getYesod runSqlPool action pool diff --git a/tests/NewAccount.hs b/tests/NewAccount.hs --- a/tests/NewAccount.hs +++ b/tests/NewAccount.hs @@ -8,6 +8,13 @@ import Text.XML.Cursor (attribute) import qualified Data.Text as T +redirectCode :: Int +#if MIN_VERSION_yesod_test(1,4,0) +redirectCode = 303 +#else +redirectCode = 302 +#endif + -- In 9f379bc219bd1fdf008e2c179b03e98a05b36401 (which went into yesod-form-1.3.9) -- the numbering of fields was changed. We normally wouldn't care because fields -- can be set via 'byLabel', but hidden fields have no label so we must use the id @@ -36,7 +43,7 @@ byLabel "Password" "xxx" byLabel "Confirm" "yyy" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "Passwords did not match" @@ -52,7 +59,7 @@ byLabel "Password" "xxx" byLabel "Confirm" "xxx" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "A confirmation e-mail has been sent to test@example.com" @@ -62,7 +69,7 @@ assertEqual "email" email "test@example.com" get' "/auth/page/account/verify/abc/zzzzzz" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "invalid verification key" @@ -73,7 +80,7 @@ post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "yyy" - statusIs 302 + statusIs redirectCode get' "/auth/login" statusIs 200 bodyContains "Invalid username/password combination" @@ -89,7 +96,7 @@ post'"/auth/page/account/resendverifyemail" $ do addNonce addPostParam f1 "abc" -- username is also a hidden field - statusIs 302 + statusIs redirectCode get' "/" bodyContains "A confirmation e-mail has been sent to test@example.com" @@ -100,13 +107,13 @@ -- verify email get' verify' - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "You are logged in as abc" post $ AuthR LogoutR - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "Please visit the Login page" @@ -116,7 +123,7 @@ post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "xxx" - statusIs 302 + statusIs redirectCode get' "/" bodyContains "You are logged in as abc" @@ -130,7 +137,7 @@ post'"/auth/page/account/resetpassword" $ do byLabel "Username" "abc" addNonce - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "A password reset email has been sent to your email address" @@ -164,7 +171,7 @@ [] -> error "Unable to find set password key" element:_ -> return $ head $ attribute "value" $ parseHTML element addPostParam f2 key - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "Password updated" @@ -177,7 +184,7 @@ post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "www" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "You are logged in as abc" @@ -193,7 +200,7 @@ byLabel "Password" "hunter2" byLabel "Confirm" "hunter2" - statusIs 302 + statusIs redirectCode get' "/" statusIs 200 bodyContains "Invalid username" -- Issue #2: a valid username was not checked on creation diff --git a/tests/main.hs b/tests/main.hs --- a/tests/main.hs +++ b/tests/main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module Main where @@ -7,16 +7,20 @@ import Test.Hspec import Yesod.Test import Database.Persist.Sqlite -import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) +import Control.Monad.Logger (runNoLoggingT) import Control.Monad.Trans.Resource (runResourceT) import BasicTests import NewAccount main :: IO () -main = withSqlitePool "test.db3" 10 $ \pool -> do - runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool - runResourceT $ runNoLoggingT $ runSqlPool (deleteWhere ([] :: [Filter User])) pool - hspec $ yesodSpec (MyApp pool) $ do +#if MIN_VERSION_persistent(2,1,0) +main = runNoLoggingT $ withSqlitePool "test.db3" 10 $ \pool -> do +#else +main = withSqlitePool "test.db3" 10 $ \pool -> runNoLoggingT $ do +#endif + runSqlPool (runMigration migrateAll) pool + runResourceT $ runSqlPool (deleteWhere ([] :: [Filter User])) pool + liftIO $ hspec $ yesodSpec (MyApp pool) $ do basicSpecs newAccountSpecs diff --git a/yesod-auth-account.cabal b/yesod-auth-account.cabal --- a/yesod-auth-account.cabal +++ b/yesod-auth-account.cabal @@ -1,5 +1,5 @@ name: yesod-auth-account -version: 1.2.6 +version: 1.4.0 cabal-version: >= 1.8 build-type: Simple synopsis: An account authentication plugin for Yesod @@ -20,6 +20,7 @@ , tests/BasicTests.hs , tests/Foundation.hs , tests/NewAccount.hs + , Changelog.md source-repository head @@ -28,21 +29,20 @@ library hs-source-dirs: . - exposed-modules: Yesod.Auth.Account + exposed-modules: Yesod.Auth.Account, Yesod.Auth.Account.Message ghc-options: -Wall -O2 build-depends: base >= 4 && < 5 - , base64-bytestring >= 1.0 , bytestring >= 0.10 , blaze-html >= 0.6 , mtl >= 2.1 + , nonce >= 1.0 , text >= 0.11 - , persistent >= 1.3 && < 1.4 + , persistent >= 1.3 && < 2.2 , pwstore-fast >= 2.0 - , random >= 1.0 - , yesod-auth >= 1.2 && < 1.4 - , yesod-core >= 1.2 && < 1.3 - , yesod-form >= 1.3 && < 1.4 + , yesod-auth >= 1.2 && < 1.5 + , yesod-core >= 1.2 && < 1.5 + , yesod-form >= 1.3 && < 1.5 , yesod-persistent >= 1.2 test-suite test @@ -60,7 +60,7 @@ , resourcet , text , xml-conduit - , yesod >= 1.2 && < 1.3 + , yesod >= 1.2 && < 1.5 , yesod-test >= 1.2.1.5 - , yesod-auth >= 1.2 && < 1.4 + , yesod-auth >= 1.2 && < 1.5 , yesod-auth-account