Merge remote-tracking branch 'upstream/master'

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-3.7
+resolver: lts-5.6
 packages:
   - ./yesod-core
   - ./yesod-static

yesod-auth-oauth/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.1
+
+* change OAuth Twitter ID, screen_name → user_id [#1168](https://github.com/yesodweb/yesod/pull/1168)
+
 ## 1.4.0.2
 
 * Compile with GHC 7.10

yesod-auth-oauth/Yesod/Auth/OAuth.hs

@@ -4,6 +4,7 @@ module Yesod.Auth.OAuth
     ( authOAuth
     , oauthUrl
     , authTwitter
+    , authTwitterUsingUserId
     , twitterUrl
     , authTumblr
     , tumblrUrl
@@ -89,11 +90,12 @@ mkExtractCreds name idName (Credential dic) = do
     Just crId -> return $ Creds name crId $ map (bsToText *** bsToText) dic
     Nothing -> throwIO $ CredentialError ("key not found: " ++ idName) (Credential dic)
 
-authTwitter :: YesodAuth m
+authTwitter' :: YesodAuth m
-            => ByteString -- ^ Consumer Key
+             => ByteString -- ^ Consumer Key
-            -> ByteString -- ^ Consumer Secret
+             -> ByteString -- ^ Consumer Secret
-            -> AuthPlugin m
+             -> String
-authTwitter key secret = authOAuth
+             -> AuthPlugin m
+authTwitter' key secret idName = authOAuth
                 (newOAuth { oauthServerName      = "twitter"
                           , oauthRequestUri      = "https://api.twitter.com/oauth/request_token"
                           , oauthAccessTokenUri  = "https://api.twitter.com/oauth/access_token"
@@ -103,7 +105,26 @@ authTwitter key secret = authOAuth
                           , oauthConsumerSecret  = secret
                           , oauthVersion         = OAuth10a
                           })
-                (mkExtractCreds "twitter" "screen_name")
+                (mkExtractCreds "twitter" idName)
+
+-- | This plugin uses Twitter's /screen_name/ as ID, which shouldn't be used for authentication because it is mutable.
+authTwitter :: YesodAuth m
+            => ByteString -- ^ Consumer Key
+            -> ByteString -- ^ Consumer Secret
+            -> AuthPlugin m
+authTwitter key secret = authTwitter' key secret "screen_name"
+{-# DEPRECATED authTwitter "Use authTwitterUsingUserID instead" #-}
+
+-- | Twitter plugin which uses Twitter's /user_id/ as ID.
+--
+-- For more information, see: https://github.com/yesodweb/yesod/pull/1168
+--
+-- @since 1.4.1
+authTwitterUsingUserId :: YesodAuth m
+                  => ByteString -- ^ Consumer Key
+                  -> ByteString -- ^ Consumer Secret
+                  -> AuthPlugin m
+authTwitterUsingUserId key secret = authTwitter' key secret "user_id"
 
 twitterUrl :: AuthRoute
 twitterUrl = oauthUrl "twitter"

yesod-auth-oauth/yesod-auth-oauth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth-oauth
-version:         1.4.0.2
+version:         1.4.1
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii

yesod-auth/ChangeLog.md

@@ -1,3 +1,8 @@
+## 1.4.13
+
+* Add a CSRF token to the login form from `Yesod.Auth.Hardcoded`, making it compatible with the CSRF middleware [#1161](https://github.com/yesodweb/yesod/pull/1161)
+* Multiple session messages. [#1187](https://github.com/yesodweb/yesod/pull/1187)
+
 ## 1.4.12
 
 * Deprecated Yesod.Auth.GoogleEmail

yesod-auth/Yesod/Auth.hs

@@ -189,9 +189,9 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     authHttpManager :: master -> Manager
 
     -- | Called on a successful login. By default, calls
-    -- @setMessageI NowLoggedIn@.
+    -- @addMessageI "success" NowLoggedIn@.
     onLogin :: HandlerT master IO ()
-    onLogin = setMessageI Msg.NowLoggedIn
+    onLogin = addMessageI "success" Msg.NowLoggedIn
 
     -- | Called on logout. By default, does nothing
     onLogout :: HandlerT master IO ()
@@ -214,10 +214,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     maybeAuthId = defaultMaybeAuthId
 
     -- | Called on login error for HTTP requests. By default, calls
-    -- @setMessage@ and redirects to @dest@.
+    -- @addMessage@ with "error" as status and redirects to @dest@.
     onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
     onErrorHtml dest msg = do
-        setMessage $ toHtml msg
+        addMessage "error" $ toHtml msg
         fmap asHtml $ redirect dest
 
     -- | runHttpRequest gives you a chance to handle an HttpException and retry

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -2,7 +2,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
+-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
+-- module is no longer recommended for use.
 module Yesod.Auth.BrowserId
+    {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
     ( authBrowserId
     , createOnClick, createOnClickOverride
     , def

yesod-auth/Yesod/Auth/Email.hs

@@ -107,6 +107,11 @@ data EmailCreds site = EmailCreds
     , emailCredsEmail  :: Email
     }
 
+data ForgotPasswordForm = ForgotPasswordForm { forgotEmail :: Text }
+data PasswordForm = PasswordForm { passwordCurrent :: Text, passwordNew :: Text, passwordConfirm :: Text }
+data UserForm = UserForm { email :: Text }
+data UserLoginForm = UserLoginForm { loginEmail :: Text, loginPassword :: Text }
+
 class ( YesodAuth site
       , PathPiece (AuthEmailId site)
       , (RenderMessage site Msg.AuthMessage)
@@ -253,30 +258,9 @@ class ( YesodAuth site
       -> AuthHandler site TypedContent
     setPasswordHandler = defaultSetPasswordHandler
 
-
+authEmail :: (YesodAuthEmail m) => AuthPlugin m
-authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
-    AuthPlugin "email" dispatch $ \tm ->
+    AuthPlugin "email" dispatch emailLoginHandler
-        [whamlet|
-$newline never
-<form method="post" action="@{tm loginR}">
-    <table>
-        <tr>
-            <th>_{Msg.Email}
-            <td>
-                <input type="email" name="email" required>
-        <tr>
-            <th>_{Msg.Password}
-            <td>
-                <input type="password" name="password" required>
-        <tr>
-            <td colspan="2">
-                <button type=submit .btn .btn-success>
-                    _{Msg.LoginViaEmail}
-                &nbsp;
-                <a href="@{tm registerR}" .btn .btn-default>
-                    _{Msg.RegisterLong}
-|]
   where
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
@@ -294,23 +278,98 @@ $newline never
 getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getRegisterR = registerHandler
 
+emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
+emailLoginHandler toParent = do
+        (widget, enctype) <- liftWidgetT $ generateFormPost loginForm
+
+        [whamlet|
+            <form method="post" action="@{toParent loginR}">
+                <div id="emailLoginForm">
+                    ^{widget}
+                    <div>
+                        <button type=submit .btn .btn-success>
+                            _{Msg.LoginViaEmail}
+                        &nbsp;
+                        <a href="@{toParent registerR}" .btn .btn-default>
+                            _{Msg.RegisterLong}
+        |]
+  where
+    loginForm extra = do
+
+        emailMsg <- renderMessage' Msg.Email
+        (emailRes, emailView) <- mreq emailField (emailSettings emailMsg) Nothing
+
+        passwordMsg <- renderMessage' Msg.Password
+        (passwordRes, passwordView) <- mreq passwordField (passwordSettings passwordMsg) Nothing
+
+        let userRes = UserLoginForm <$> emailRes <*> passwordRes
+        let widget = do
+            [whamlet|
+                #{extra}
+                <div>
+                    ^{fvInput emailView}
+                <div>
+                    ^{fvInput passwordView}
+            |]
+
+        return (userRes, widget)
+    emailSettings emailMsg = do
+        FieldSettings {
+            fsLabel = SomeMessage Msg.Email,
+            fsTooltip = Nothing,
+            fsId = Just "email",
+            fsName = Just "email",
+            fsAttrs = [("autofocus", ""), ("placeholder", emailMsg)]
+        }
+    passwordSettings passwordMsg =
+         FieldSettings {
+            fsLabel = SomeMessage Msg.Password,
+            fsTooltip = Nothing,
+            fsId = Just "password",
+            fsName = Just "password",
+            fsAttrs = [("placeholder", passwordMsg)]
+        }
+    renderMessage' msg = do
+        langs <- languages
+        master <- getYesod
+        return $ renderAuthMessage master langs msg
 -- | Default implementation of 'registerHandler'.
 --
 -- Since: 1.2.6
 defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
 defaultRegisterHandler = do
-    email <- newIdent
+    (widget, enctype) <- lift $ generateFormPost registrationForm
-    tp <- getRouteToParent
+    toParentRoute <- getRouteToParent
     lift $ authLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
             <p>_{Msg.EnterEmail}
-            <form method="post" action="@{tp registerR}">
+            <form method="post" action="@{toParentRoute registerR}" enctype=#{enctype}>
                 <div id="registerForm">
-                    <label for=#{email}>_{Msg.Email}:
+                    ^{widget}
-                    <input ##{email} type="email" name="email" width="150" autofocus>
                 <button .btn>_{Msg.Register}
         |]
+    where
+        registrationForm extra = do
+            let emailSettings = FieldSettings {
+                fsLabel = SomeMessage Msg.Email,
+                fsTooltip = Nothing,
+                fsId = Just "email",
+                fsName = Just "email",
+                fsAttrs = [("autofocus", "")]
+            }
+
+            (emailRes, emailView) <- mreq emailField emailSettings Nothing
+
+            let userRes = UserForm <$> emailRes
+            let widget = do
+                [whamlet|
+                    #{extra}
+                    ^{fvLabel emailView}
+                    ^{fvInput emailView}
+                |]
+
+            return (userRes, widget)
 
 registerHelper :: YesodAuthEmail master
                => Bool -- ^ allow usernames?
@@ -365,18 +424,38 @@ getForgotPasswordR = forgotPasswordHandler
 -- Since: 1.2.6
 defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
 defaultForgotPasswordHandler = do
-    tp <- getRouteToParent
+    (widget, enctype) <- lift $ generateFormPost forgotPasswordForm
-    email <- newIdent
+    toParent <- getRouteToParent
     lift $ authLayout $ do
         setTitleI Msg.PasswordResetTitle
         [whamlet|
             <p>_{Msg.PasswordResetPrompt}
-            <form method="post" action="@{tp forgotPasswordR}">
+            <form method=post action=@{toParent forgotPasswordR} enctype=#{enctype}>
-                <div id="registerForm">
+                <div id="forgotPasswordForm">
-                    <label for=#{email}>_{Msg.ProvideIdentifier}
+                    ^{widget}
-                    <input ##{email} type=text name="email" width="150" autofocus>
+                    <button .btn>_{Msg.SendPasswordResetEmail}
-                <button .btn>_{Msg.SendPasswordResetEmail}
         |]
+  where
+    forgotPasswordForm extra = do
+        (emailRes, emailView) <- mreq emailField emailSettings Nothing
+    
+        let forgotPasswordRes = ForgotPasswordForm <$> emailRes
+        let widget = do
+            [whamlet|
+                #{extra}
+                ^{fvLabel emailView}
+                ^{fvInput emailView}
+            |]
+        return (forgotPasswordRes, widget)
+
+    emailSettings =
+        FieldSettings {
+            fsLabel = SomeMessage Msg.ProvideIdentifier,
+            fsTooltip = Nothing,
+            fsId = Just "forgotPassword",
+            fsName = Just "email",
+            fsAttrs = [("autofocus", "")]
+        }
 
 postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postForgotPasswordR = registerHelper True forgotPasswordR
@@ -400,7 +479,7 @@ getVerifyR lid key = do
                     let msgAv = Msg.AddressVerified
                     selectRep $ do
                       provideRep $ do
-                        lift $ setMessageI msgAv
+                        lift $ addMessageI "success" msgAv
                         fmap asHtml $ redirect setpassR
                       provideJsonMessage $ mr msgAv
         _ -> invalidKey mr
@@ -461,40 +540,77 @@ getPasswordR = do
 -- Since: 1.2.6
 defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
 defaultSetPasswordHandler needOld = do
-    tp <- getRouteToParent
+    messageRender <- lift getMessageRender
-    pass0 <- newIdent
+    toParent <- getRouteToParent
-    pass1 <- newIdent
-    pass2 <- newIdent
-    mr <- lift getMessageRender
     selectRep $ do
-      provideJsonMessage $ mr Msg.SetPass
+        provideJsonMessage $ messageRender Msg.SetPass
-      provideRep $ lift $ authLayout $ do
+        provideRep $ lift $ authLayout $ do
-          setTitleI Msg.SetPassTitle
+            (widget, enctype) <- liftWidgetT $ generateFormPost $ setPasswordForm needOld
-          [whamlet|
+            setTitleI Msg.SetPassTitle
-$newline never
+            [whamlet|
-<h3>_{Msg.SetPass}
+                <h3>_{Msg.SetPass}
-<form method="post" action="@{tp setpassR}">
+                <form method="post" action="@{toParent setpassR}">
-    <table>
+                    ^{widget}
-        $if needOld
+            |]
-            <tr>
+  where
-                <th>
+    setPasswordForm needOld extra = do
-                    <label for=#{pass0}>Current Password
+        (currentPasswordRes, currentPasswordView) <- mreq passwordField currentPasswordSettings Nothing
-                <td>
+        (newPasswordRes, newPasswordView) <- mreq passwordField newPasswordSettings Nothing
-                    <input ##{pass0} type="password" name="current" autofocus>
+        (confirmPasswordRes, confirmPasswordView) <- mreq passwordField confirmPasswordSettings Nothing
-        <tr>
+
-            <th>
+        let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes
-                <label for=#{pass1}>_{Msg.NewPass}
+        let widget = do
-            <td>
+            [whamlet|
-                <input ##{pass1} type="password" name="new" :not needOld:autofocus>
+                #{extra}
-        <tr>
+                <table>
-            <th>
+                    $if needOld
-                <label for=#{pass2}>_{Msg.ConfirmPass}
+                        <tr>
-            <td>
+                            <th>
-                <input ##{pass2} type="password" name="confirm">
+                                ^{fvLabel currentPasswordView}
-        <tr>
+                            <td>
-            <td colspan="2">
+                                ^{fvInput currentPasswordView}
-                <input type="submit" value=_{Msg.SetPassTitle}>
+                    <tr>
-|]
+                        <th>
+                            ^{fvLabel newPasswordView}
+                        <td>
+                            ^{fvInput newPasswordView}
+                    <tr>
+                        <th>
+                            ^{fvLabel confirmPasswordView}
+                        <td>
+                            ^{fvInput confirmPasswordView}
+                    <tr>
+                        <td colspan="2">
+                            <input type=submit value=_{Msg.SetPassTitle}>
+            |]
+
+        return (passwordFormRes, widget)
+    currentPasswordSettings =
+         FieldSettings {
+             fsLabel = SomeMessage Msg.CurrentPassword,
+             fsTooltip = Nothing,
+             fsId = Just "currentPassword",
+             fsName = Just "current",
+             fsAttrs = [("autofocus", "")]
+         }
+    newPasswordSettings =
+        FieldSettings {
+            fsLabel = SomeMessage Msg.NewPass,
+            fsTooltip = Nothing,
+            fsId = Just "newPassword",
+            fsName = Just "new",
+            fsAttrs = [("autofocus", ""), (":not", ""), ("needOld:autofocus", "")]
+        }
+    confirmPasswordSettings =
+        FieldSettings {
+            fsLabel = SomeMessage Msg.ConfirmPass,
+            fsTooltip = Nothing,
+            fsId = Just "confirmPassword",
+            fsName = Just "confirm",
+            fsAttrs = [("autofocus", "")]
+        }
+
+
 
 postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postPasswordR = do
@@ -534,7 +650,7 @@ postPasswordR = do
                       y <- lift $ do
                           setPassword aid salted
                           deleteSession loginLinkKey
-                          setMessageI msgOk
+                          addMessageI "success" msgOk
                           getYesod
 
                       mr <- lift getMessageRender

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -59,7 +59,7 @@ import           Yesod.Core               (HandlerSite, HandlerT, MonadHandler,
                                            lift, liftIO, lookupGetParam,
                                            lookupSession, notFound, redirect,
                                            setSession, whamlet, (.:),
-                                           setMessage, getYesod, authRoute,
+                                           addMessage, getYesod, authRoute,
                                            toHtml)
 
 
@@ -200,7 +200,7 @@ authPlugin storeToken clientID clientSecret =
                                     case err of
                                         "access_denied" -> "Access denied"
                                         _ -> "Unknown error occurred: " `T.append` err
-                            setMessage $ toHtml msg
+                            addMessage "error" $ toHtml msg
                             lift $ redirect $ logoutDest master
                 Just c -> return c
 

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -160,10 +160,13 @@ authHardcoded =
   where
     dispatch "POST" ["login"] = postLoginR >>= sendResponse
     dispatch _ _ = notFound
-    loginWidget toMaster =
+    loginWidget toMaster = do
+      request <- getRequest
       [whamlet|
         $newline never
         <form method="post" action="@{toMaster loginR}">
+          $maybe t <- reqToken request
+            <input type=hidden name=#{defaultCsrfParamName} value=#{t}>
           <table>
             <tr>
               <th>_{Msg.UserName}

yesod-auth/Yesod/Auth/Message.hs

@@ -17,9 +17,10 @@ module Yesod.Auth.Message
     , czechMessage
     , russianMessage
     , dutchMessage
+    , danishMessage
     ) where
 
-import           Data.Monoid (mappend,(<>))
+import           Data.Monoid (mappend, (<>))
 import           Data.Text   (Text)
 
 data AuthMessage =
@@ -60,6 +61,7 @@ data AuthMessage =
     | ProvideIdentifier
     | SendPasswordResetEmail
     | PasswordResetPrompt
+    | CurrentPassword
     | InvalidUsernamePass
     | Logout
     | LogoutTitle
@@ -78,6 +80,7 @@ englishMessage LoginYahoo = "Login via Yahoo"
 englishMessage Email = "Email"
 englishMessage UserName = "User name"
 englishMessage Password = "Password"
+englishMessage CurrentPassword = "Current Password"
 englishMessage Register = "Register"
 englishMessage RegisterLong = "Register a new account"
 englishMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
@@ -124,6 +127,7 @@ portugueseMessage LoginYahoo = "Entrar via Yahoo"
 portugueseMessage Email = "E-mail"
 portugueseMessage UserName = "Nome de usuário" -- FIXME by Google Translate "user name"
 portugueseMessage Password = "Senha"
+portugueseMessage CurrentPassword = "Palavra de passe"
 portugueseMessage Register = "Registrar"
 portugueseMessage RegisterLong = "Registrar uma nova conta"
 portugueseMessage EnterEmail = "Por favor digite seu endereço de e-mail abaixo e um e-mail de confirmação será enviado para você."
@@ -171,6 +175,7 @@ spanishMessage LoginYahoo = "Entrar utilizando Yahoo"
 spanishMessage Email = "Correo electrónico"
 spanishMessage UserName = "Nombre de Usuario" -- FIXME by Google Translate "user name"
 spanishMessage Password = "Contraseña"
+spanishMessage CurrentPassword = "Contraseña actual"
 spanishMessage Register = "Registrarse"
 spanishMessage RegisterLong = "Registrar una nueva cuenta"
 spanishMessage EnterEmail = "Coloque su dirección de correo electrónico, y un correo de confirmación le será enviado a su cuenta."
@@ -218,6 +223,7 @@ swedishMessage LoginYahoo = "Logga in via Yahoo"
 swedishMessage Email = "Epost"
 swedishMessage UserName = "Användarnamn"  -- FIXME by Google Translate "user name"
 swedishMessage Password = "Lösenord"
+swedishMessage CurrentPassword = "Current password"
 swedishMessage Register = "Registrera"
 swedishMessage RegisterLong = "Registrera ett nytt konto"
 swedishMessage EnterEmail = "Skriv in din epost nedan så kommer ett konfirmationsmail skickas till adressen."
@@ -266,6 +272,7 @@ germanMessage LoginYahoo = "Login via Yahoo"
 germanMessage Email = "Email"
 germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"
 germanMessage Password = "Passwort"
+germanMessage CurrentPassword = "Aktuelles Passwort"
 germanMessage Register = "Registrieren"
 germanMessage RegisterLong = "Neuen Account registrieren"
 germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."
@@ -313,6 +320,7 @@ frenchMessage LoginYahoo = "Se connecter avec Yahoo"
 frenchMessage Email = "Adresse électronique"
 frenchMessage UserName = "Nom d'utilisateur" -- FIXME by Google Translate "user name"
 frenchMessage Password = "Mot de passe"
+frenchMessage CurrentPassword = "Mot de passe actuel"
 frenchMessage Register = "S'inscrire"
 frenchMessage RegisterLong = "Créer un compte"
 frenchMessage EnterEmail = "Entrez ci-dessous votre adresse électronique, et un message de confirmation vous sera envoyé"
@@ -359,6 +367,7 @@ norwegianBokmålMessage LoginYahoo = "Logg inn med Yahoo"
 norwegianBokmålMessage Email = "E-post"
 norwegianBokmålMessage UserName = "Brukernavn" -- FIXME by Google Translate "user name"
 norwegianBokmålMessage Password = "Passord"
+norwegianBokmålMessage CurrentPassword = "Current password"
 norwegianBokmålMessage Register = "Registrer"
 norwegianBokmålMessage RegisterLong = "Registrer en ny konto"
 norwegianBokmålMessage EnterEmail = "Skriv inn e-postadressen din nedenfor og en e-postkonfirmasjon vil bli sendt."
@@ -406,6 +415,7 @@ japaneseMessage LoginYahoo = "Yahooでログイン"
 japaneseMessage Email = "Eメール"
 japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name"
 japaneseMessage Password = "パスワード"
+japaneseMessage CurrentPassword = "Current password"
 japaneseMessage Register = "登録"
 japaneseMessage RegisterLong = "新規アカウント登録"
 japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"
@@ -453,6 +463,7 @@ finnishMessage LoginYahoo = "Kirjaudu Yahoo-tilillä"
 finnishMessage Email = "Sähköposti"
 finnishMessage UserName = "Käyttäjätunnus" -- FIXME by Google Translate "user name"
 finnishMessage Password = "Salasana"
+finnishMessage Password = "Current password"
 finnishMessage Register = "Luo uusi"
 finnishMessage RegisterLong = "Luo uusi tili"
 finnishMessage EnterEmail = "Kirjoita alle sähköpostiosoitteesi, johon vahvistussähköposti lähetetään."
@@ -501,6 +512,7 @@ chineseMessage LoginYahoo = "用Yahoo帐户登录"
 chineseMessage Email = "邮箱"
 chineseMessage UserName = "用户名" -- FIXME by Google Translate "user name"
 chineseMessage Password = "密码"
+chineseMessage CurrentPassword = "Current password"
 chineseMessage Register = "注册"
 chineseMessage RegisterLong = "注册新帐户"
 chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
@@ -548,6 +560,7 @@ czechMessage LoginYahoo = "Přihlásit přes Yahoo"
 czechMessage Email = "E-mail"
 czechMessage UserName = "Uživatelské jméno"
 czechMessage Password = "Heslo"
+czechMessage CurrentPassword = "Current password"
 czechMessage Register = "Registrovat"
 czechMessage RegisterLong = "Zaregistrovat nový účet"
 czechMessage EnterEmail = "Níže zadejte svou e-mailovou adresu a bude vám poslán potvrzovací e-mail."
@@ -595,6 +608,7 @@ russianMessage LoginYahoo = "Вход с помощью Yahoo"
 russianMessage Email = "Эл.почта"
 russianMessage UserName = "Имя пользователя"
 russianMessage Password = "Пароль"
+russianMessage CurrentPassword = "Current password"
 russianMessage Register = "Регистрация"
 russianMessage RegisterLong = "Создать учётную запись"
 russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."
@@ -611,7 +625,7 @@ russianMessage BadSetPass = "Чтобы изменить пароль, необ
 russianMessage SetPassTitle = "Установить пароль"
 russianMessage SetPass = "Установить новый пароль"
 russianMessage NewPass = "Новый пароль"
-russianMessage ConfirmPass = "Подтверждение"
+russianMessage ConfirmPass = "Подтверждение пароля"
 russianMessage PassMismatch = "Пароли не совпадают, повторите снова"
 russianMessage PassUpdated = "Пароль обновлён"
 russianMessage Facebook = "Войти с помощью Facebook"
@@ -641,6 +655,7 @@ dutchMessage LoginYahoo = "Inloggen via Yahoo"
 dutchMessage Email = "E-mail"
 dutchMessage UserName = "Gebruikersnaam" -- FIXME by Google Translate "user name"
 dutchMessage Password = "Wachtwoord"
+dutchMessage CurrentPassword = "Current password"
 dutchMessage Register = "Registreren"
 dutchMessage RegisterLong = "Registreer een nieuw account"
 dutchMessage EnterEmail = "Voer uw e-mailadres hieronder in, er zal een bevestigings-e-mail naar u worden verzonden."
@@ -680,44 +695,92 @@ dutchMessage LogoutTitle = "Log Out" -- FIXME NOT TRANSLATED
 dutchMessage AuthError = "Verificatiefout" -- FIXME by Google Translate
 
 croatianMessage :: AuthMessage -> Text
-croatianMessage NoOpenID      = "Nije pronađen OpenID identifikator"
+croatianMessage NoOpenID = "Nije pronađen OpenID identifikator"
-croatianMessage LoginOpenID   = "Prijava uz OpenID"
+croatianMessage LoginOpenID = "Prijava uz OpenID"
-croatianMessage LoginGoogle   = "Prijava uz Google"
+croatianMessage LoginGoogle = "Prijava uz Google"
-croatianMessage LoginYahoo    = "Prijava uz Yahoo"
+croatianMessage LoginYahoo = "Prijava uz Yahoo"
-croatianMessage Facebook      = "Prijava uz Facebook"
+croatianMessage Facebook = "Prijava uz Facebook"
 croatianMessage LoginViaEmail = "Prijava putem e-pošte"
-croatianMessage Email         = "E-pošta"
+croatianMessage Email = "E-pošta"
-croatianMessage UserName      = "Korisničko ime"
+croatianMessage UserName = "Korisničko ime"
-croatianMessage Password      = "Lozinka"
+croatianMessage Password = "Lozinka"
-croatianMessage Register      = "Registracija"
+croatianMessage CurrentPassword = "Current Password"
-croatianMessage RegisterLong  = "Registracija novog računa"
+croatianMessage Register = "Registracija"
-croatianMessage EnterEmail          = "Dolje unesite adresu e-pošte, pa ćemo vam poslati e-poruku za potvrdu."
+croatianMessage RegisterLong = "Registracija novog računa"
+croatianMessage EnterEmail = "Dolje unesite adresu e-pošte, pa ćemo vam poslati e-poruku za potvrdu."
 croatianMessage PasswordResetPrompt = "Dolje unesite adresu e-pošte ili korisničko ime, pa ćemo vam poslati e-poruku za potvrdu."
-croatianMessage ConfirmationEmailSentTitle    = "E-poruka za potvrdu"
+croatianMessage ConfirmationEmailSentTitle = "E-poruka za potvrdu"
 croatianMessage (ConfirmationEmailSent email) = "E-poruka za potvrdu poslana je na adresu " <> email <> "."
-croatianMessage AddressVerified               = "Adresa ovjerena, postavite novu lozinku"
+croatianMessage AddressVerified = "Adresa ovjerena, postavite novu lozinku"
-croatianMessage InvalidKeyTitle               = "Ključ za ovjeru nije valjan"
+croatianMessage InvalidKeyTitle = "Ključ za ovjeru nije valjan"
-croatianMessage InvalidKey                    = "Nažalost, taj ključ za ovjeru nije valjan."
+croatianMessage InvalidKey = "Nažalost, taj ključ za ovjeru nije valjan."
-croatianMessage InvalidEmailPass              = "Kombinacija e-pošte i lozinke nije valjana"
+croatianMessage InvalidEmailPass = "Kombinacija e-pošte i lozinke nije valjana"
-croatianMessage InvalidUsernamePass           = "Kombinacija korisničkog imena i lozinke nije valjana"
+croatianMessage InvalidUsernamePass = "Kombinacija korisničkog imena i lozinke nije valjana"
-croatianMessage BadSetPass                    = "Za postavljanje lozinke morate biti prijavljeni"
+croatianMessage BadSetPass = "Za postavljanje lozinke morate biti prijavljeni"
-croatianMessage SetPassTitle                  = "Postavi lozinku"
+croatianMessage SetPassTitle = "Postavi lozinku"
-croatianMessage SetPass                       = "Postavite novu lozinku"
+croatianMessage SetPass = "Postavite novu lozinku"
-croatianMessage NewPass                       = "Nova lozinka"
+croatianMessage NewPass = "Nova lozinka"
-croatianMessage ConfirmPass                   = "Potvrda lozinke"
+croatianMessage ConfirmPass = "Potvrda lozinke"
-croatianMessage PassMismatch                  = "Lozinke se ne podudaraju, pokušajte ponovo"
+croatianMessage PassMismatch = "Lozinke se ne podudaraju, pokušajte ponovo"
-croatianMessage PassUpdated                   = "Lozinka ažurirana"
+croatianMessage PassUpdated = "Lozinka ažurirana"
-croatianMessage InvalidLogin                  = "Prijava nije valjana"
+croatianMessage InvalidLogin = "Prijava nije valjana"
-croatianMessage NowLoggedIn                   = "Sada ste prijavljeni u"
+croatianMessage NowLoggedIn = "Sada ste prijavljeni u"
-croatianMessage LoginTitle                    = "Prijava"
+croatianMessage LoginTitle = "Prijava"
-croatianMessage PleaseProvideUsername         = "Unesite korisničko ime"
+croatianMessage PleaseProvideUsername = "Unesite korisničko ime"
-croatianMessage PleaseProvidePassword         = "Unesite lozinku"
+croatianMessage PleaseProvidePassword = "Unesite lozinku"
-croatianMessage NoIdentifierProvided          = "Nisu dani e-pošta/korisničko ime"
+croatianMessage NoIdentifierProvided = "Nisu dani e-pošta/korisničko ime"
-croatianMessage InvalidEmailAddress           = "Dana adresa e-pošte nije valjana"
+croatianMessage InvalidEmailAddress = "Dana adresa e-pošte nije valjana"
-croatianMessage PasswordResetTitle            = "Poništavanje lozinke"
+croatianMessage PasswordResetTitle = "Poništavanje lozinke"
-croatianMessage ProvideIdentifier             = "E-pošta ili korisničko ime"
+croatianMessage ProvideIdentifier = "E-pošta ili korisničko ime"
-croatianMessage SendPasswordResetEmail        = "Pošalji e-poruku za poništavanje lozinke"
+croatianMessage SendPasswordResetEmail = "Pošalji e-poruku za poništavanje lozinke"
-croatianMessage (IdentifierNotFound ident)    = "Korisničko ime/e-pošta nisu pronađeni: " <> ident
+croatianMessage (IdentifierNotFound ident) = "Korisničko ime/e-pošta nisu pronađeni: " <> ident
-croatianMessage Logout                        = "Odjava"
+croatianMessage Logout = "Odjava"
-croatianMessage LogoutTitle                   = "Odjava"
+croatianMessage LogoutTitle = "Odjava"
-croatianMessage AuthError                     = "Pogreška provjere autentičnosti"
+croatianMessage AuthError = "Pogreška provjere autentičnosti"
+
+danishMessage :: AuthMessage -> Text
+danishMessage NoOpenID = "Mangler OpenID identifier"
+danishMessage LoginOpenID = "Login med OpenID"
+danishMessage LoginGoogle = "Login med Google"
+danishMessage LoginYahoo = "Login med Yahoo"
+danishMessage Email = "E-mail"
+danishMessage UserName = "Brugernavn"
+danishMessage Password = "Kodeord"
+danishMessage CurrentPassword = "Nuværende kodeord"
+danishMessage Register = "Opret"
+danishMessage RegisterLong = "Opret en ny konto"
+danishMessage EnterEmail = "Indtast din e-mailadresse nedenfor og en bekræftelsesmail vil blive sendt til dig."
+danishMessage ConfirmationEmailSentTitle = "Bekræftelsesmail sendt"
+danishMessage (ConfirmationEmailSent email) =
+    "En bekræftelsesmail er sendt til " `mappend`
+    email `mappend`
+    "."
+danishMessage AddressVerified = "Adresse bekræftet, sæt venligst et nyt kodeord"
+danishMessage InvalidKeyTitle = "Ugyldig verifikationsnøgle"
+danishMessage InvalidKey = "Beklager, det var en ugyldigt verifikationsnøgle."
+danishMessage InvalidEmailPass = "Ugyldigt e-mail/kodeord"
+danishMessage BadSetPass = "Du skal være logget ind for at sætte et kodeord"
+danishMessage SetPassTitle = "Sæt kodeord"
+danishMessage SetPass = "Sæt et nyt kodeord"
+danishMessage NewPass = "Nyt kodeord"
+danishMessage ConfirmPass = "Bekræft"
+danishMessage PassMismatch = "Kodeordne var forskellige, prøv venligst igen"
+danishMessage PassUpdated = "Kodeord opdateret"
+danishMessage Facebook = "Login med Facebook"
+danishMessage LoginViaEmail = "Login med e-mail"
+danishMessage InvalidLogin = "Ugyldigt login"
+danishMessage NowLoggedIn = "Du er nu logget ind"
+danishMessage LoginTitle = "Log ind"
+danishMessage PleaseProvideUsername = "Indtast venligst dit brugernavn"
+danishMessage PleaseProvidePassword = "Indtasy venligst dit kodeord"
+danishMessage NoIdentifierProvided = "Mangler e-mail/username"
+danishMessage InvalidEmailAddress = "Ugyldig e-mailadresse indtastet"
+danishMessage PasswordResetTitle = "Nulstilning af kodeord"
+danishMessage ProvideIdentifier = "E-mail eller brugernavn"
+danishMessage SendPasswordResetEmail = "Send kodeordsnulstillingsmail"
+danishMessage PasswordResetPrompt = "Indtast din e-mailadresse eller dit brugernavn nedenfor, så bliver en kodeordsnulstilningsmail sendt til dig."
+danishMessage InvalidUsernamePass = "Ugyldigt brugernavn/kodeord"
+danishMessage (IdentifierNotFound ident) = "Brugernavn findes ikke: " `mappend` ident
+danishMessage Logout = "Log ud"
+danishMessage LogoutTitle = "Log ud"
+danishMessage AuthError = "Fejl ved bekræftelse af identitet"

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.4.12
+version:         1.4.13
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -23,7 +23,7 @@ library
     build-depends:   base                    >= 4         && < 5
                    , authenticate            >= 1.3
                    , bytestring              >= 0.9.1.4
-                   , yesod-core              >= 1.4       && < 1.5
+                   , yesod-core              >= 1.4.20    && < 1.5
                    , wai                     >= 1.4
                    , template-haskell
                    , base16-bytestring

yesod-bin/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.18
+
+* Disable `yesod test` when using Stack [#1198](https://github.com/yesodweb/yesod/issues/1198)
+
 ## 1.4.17
 
 * Fully remove the `yesod init` command

yesod-bin/Keter.hs

@@ -6,11 +6,12 @@ module Keter
 import Data.Yaml
 import qualified Data.HashMap.Strict as Map
 import qualified Data.Text as T
+import System.Environment (getEnvironment)
 import System.Exit
 import System.Process
 import Control.Monad
 import System.Directory hiding (findFiles)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe,isJust,maybeToList)
 import Data.Monoid
 import System.FilePath ((</>))
 import qualified Codec.Archive.Tar as Tar
@@ -48,6 +49,8 @@ keter cabal noBuild noCopyTo buildArgs = do
                             _ -> return value
             Just _ -> error $ ketercfg ++ " is not an object"
 
+    env' <- getEnvironment
+    cwd' <- getCurrentDirectory
     files <- getDirectoryContents "."
     project <-
         case mapMaybe (T.stripSuffix ".cabal" . T.pack) files of
@@ -74,15 +77,27 @@ keter cabal noBuild noCopyTo buildArgs = do
         collapse' (x:xs) = x : collapse' xs
         collapse' [] = []
 
-    unless noBuild $ if elem "stack.yaml" files
+    unless noBuild $ do
-        then do run "stack" ["clean"]
+        stackQueryRunSuccess <- do
-                createDirectoryIfMissing True "./dist/bin"
+            (ec,_,_) <- readProcessWithExitCode "stack" ["query"] ""
-                run "stack"
+            return (ec == ExitSuccess)
-                    ((words "--local-bin-path ./dist/bin build --copy-bins")
+
-                     <> buildArgs)
+        let inStackExec = isJust $ lookup "STACK_EXE" env'
-        else do run cabal ["clean"]
+            mStackYaml = lookup "STACK_YAML" env'
-                run cabal ["configure"]
+            useStack = inStackExec || isJust mStackYaml || stackQueryRunSuccess
-                run cabal ("build" : buildArgs)
+
+        if useStack
+            then do let stackYaml = maybeToList $ fmap ("--stack-yaml="<>) mStackYaml
+                        localBinPath = cwd' </> "dist/bin"
+                    run "stack" $ stackYaml <> ["clean"]
+                    createDirectoryIfMissing True localBinPath
+                    run "stack"
+                        (stackYaml
+                         <> ["--local-bin-path",localBinPath,"build","--copy-bins"]
+                         <> buildArgs)
+            else do run cabal ["clean"]
+                    run cabal ["configure"]
+                    run cabal ("build" : buildArgs)
 
     _ <- try' $ removeDirectoryRecursive "static/tmp"
 

yesod-bin/main.hs

@@ -6,7 +6,7 @@ import           Data.Monoid
 import           Data.Version           (showVersion)
 import           Options.Applicative
 import           System.Environment     (getEnvironment)
-import           System.Exit            (ExitCode (ExitSuccess), exitWith)
+import           System.Exit            (ExitCode (ExitSuccess), exitWith, exitFailure)
 import           System.FilePath        (splitSearchPath)
 import           System.Process         (rawSystem)
 
@@ -15,6 +15,7 @@ import           Devel                  (DevelOpts (..), devel, DevelTermOpt(..)
 import           Keter                  (keter)
 import           Options                (injectDefaults)
 import qualified Paths_yesod_bin
+import           System.IO              (hPutStrLn, stderr)
 
 import           HsFile                 (mkHsFile)
 #ifndef WINDOWS
@@ -130,10 +131,18 @@ main = do
                              }
                        devel develOpts develExtraArgs
   where
-    cabalTest cabal = do touch'
+    cabalTest cabal = do
-                         _ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
+        env <- getEnvironment
-                         _ <- cabal ["build"]
+        case lookup "STACK_EXE" env of
-                         cabal ["test"]
+            Nothing -> do
+                touch'
+                _ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
+                _ <- cabal ["build"]
+                cabal ["test"]
+            Just _ -> do
+                hPutStrLn stderr "'yesod test' is no longer needed with Stack"
+                hPutStrLn stderr "Instead, please just run 'stack test'"
+                exitFailure
 
 handleGhcPackagePath :: IO ([String], Maybe [(String, String)])
 handleGhcPackagePath = do

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.4.17.1
+version:         1.4.18
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

yesod-core/ChangeLog.md

@@ -1,3 +1,15 @@
+## 1.4.20.1
+
+* Log a warning when a CSRF error occurs [#1200](https://github.com/yesodweb/yesod/pull/1200)
+
+## 1.4.20
+
+* `addMessage`, `addMessageI`, and `getMessages` functions
+
+## 1.4.19.1
+
+* Allow lines of dashes in route files [#1182](https://github.com/yesodweb/yesod/pull/1182)
+
 ## 1.4.19
 
 * Auth logout not working with defaultCsrfMiddleware [#1151](https://github.com/yesodweb/yesod/issues/1151)

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -87,7 +87,7 @@ class RenderRoute site => Yesod site where
     defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
     defaultLayout w = do
         p <- widgetToPageContent w
-        mmsg <- getMessage
+        msgs <- getMessages
         withUrlRenderer [hamlet|
             $newline never
             $doctype 5
@@ -96,8 +96,8 @@ class RenderRoute site => Yesod site where
                     <title>#{pageTitle p}
                     ^{pageHead p}
                 <body>
-                    $maybe msg <- mmsg
+                    $forall (status, msg) <- msgs
-                        <p .message>#{msg}
+                        <p class="message #{status}">#{msg}
                     ^{pageBody p}
             |]
 

yesod-core/Yesod/Core/Handler.hs

@@ -136,6 +136,9 @@ module Yesod.Core.Handler
     , redirectUltDest
     , clearUltDest
       -- ** Messages
+    , addMessage
+    , addMessageI
+    , getMessages
     , setMessage
     , setMessageI
     , getMessage
@@ -205,7 +208,7 @@ import qualified Data.Text                     as T
 import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
 import           Data.Text.Encoding.Error      (lenientDecode)
 import qualified Data.Text.Lazy                as TL
-import qualified Text.Blaze.Html.Renderer.Text as RenderText
+import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import           Text.Hamlet                   (Html, HtmlUrl, hamlet)
 
 import qualified Data.ByteString               as S
@@ -223,7 +226,7 @@ import           Text.Shakespeare.I18N         (RenderMessage (..))
 import           Web.Cookie                    (SetCookie (..))
 import           Yesod.Core.Content            (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
 import           Yesod.Core.Internal.Util      (formatRFC1123)
-import           Text.Blaze.Html               (preEscapedToMarkup, toHtml)
+import           Text.Blaze.Html               (preEscapedToHtml, toHtml)
 
 import qualified Data.IORef.Lifted             as I
 import           Data.Maybe                    (listToMaybe, mapMaybe)
@@ -249,6 +252,7 @@ import qualified Yesod.Core.TypeCache as Cache
 import qualified Data.Word8 as W8
 import qualified Data.Foldable as Fold
 import Data.Default
+import Control.Monad.Logger (MonadLogger, logWarnS)
 
 get :: MonadHandler m => m GHState
 get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -521,30 +525,66 @@ clearUltDest = deleteSession ultDestKey
 msgKey :: Text
 msgKey = "_MSG"
 
--- | Sets a message in the user's session.
+-- | Adds a status and message in the user's session.
 --
--- See 'getMessage'.
+-- See 'getMessages'.
-setMessage :: MonadHandler m => Html -> m ()
+--
-setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
+-- @since 1.4.20
+addMessage :: MonadHandler m
+           => Text -- ^ status
+           -> Html -- ^ message
+           -> m ()
+addMessage status msg = do
+    val <- lookupSessionBS msgKey
+    setSessionBS msgKey $ addMsg val
+  where
+    addMsg = maybe msg' (S.append msg' . S.cons W8._nul)
+    msg' = S.append
+        (encodeUtf8 status)
+        (W8._nul `S.cons` (L.toStrict $ renderHtml msg))
 
--- | Sets a message in the user's session.
+-- | Adds a message in the user's session but uses RenderMessage to allow for i18n
 --
--- See 'getMessage'.
+-- See 'getMessages'.
+--
+-- @since 1.4.20
+addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
+            => Text -> msg -> m ()
+addMessageI status msg = do
+    mr <- getMessageRender
+    addMessage status $ toHtml $ mr msg
+
+-- | Gets all messages in the user's session, and then clears the variable.
+--
+-- See 'addMessage'.
+--
+-- @since 1.4.20
+getMessages :: MonadHandler m => m [(Text, Html)]
+getMessages = do
+    bs <- lookupSessionBS msgKey
+    let ms = maybe [] enlist bs
+    deleteSession msgKey
+    return ms
+  where
+    enlist = pairup . S.split W8._nul
+    pairup [] = []
+    pairup [x] = []
+    pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs
+    decode = decodeUtf8With lenientDecode
+
+-- | Calls 'addMessage' with an empty status
+setMessage :: MonadHandler m => Html -> m ()
+setMessage = addMessage ""
+
+-- | Calls 'addMessageI' with an empty status
 setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
             => msg -> m ()
-setMessageI msg = do
+setMessageI = addMessageI ""
-    mr <- getMessageRender
-    setMessage $ toHtml $ mr msg
 
--- | Gets the message in the user's session, if available, and then clears the
+-- | Gets just the last message in the user's session,
--- variable.
+-- discards the rest and the status
---
--- See 'setMessage'.
 getMessage :: MonadHandler m => m (Maybe Html)
-getMessage = do
+getMessage = (return . fmap snd . headMay) =<< getMessages
-    mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
-    deleteSession msgKey
-    return mmsg
 
 -- | Bypass remaining handler code and output the given file.
 --
@@ -580,6 +620,8 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent
 
 -- | Bypass remaining handler code and output the given JSON with the given
 -- status code.
+-- 
+-- Since 1.4.18
 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
 sendStatusJSON s v = sendResponseStatus s (toJSON v)
 
@@ -1398,14 +1440,16 @@ hasValidCsrfParamNamed paramName = do
 -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.
 --
 -- Since 1.4.14
-checkCsrfHeaderOrParam :: MonadHandler m
+checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)
                        => CI S8.ByteString -- ^ The header name to lookup the CSRF token
                        -> Text -- ^ The POST parameter name to lookup the CSRF token
                        -> m ()
 checkCsrfHeaderOrParam headerName paramName = do
   validHeader <- hasValidCsrfHeaderNamed headerName
   validParam <- hasValidCsrfParamNamed paramName
-  unless (validHeader || validParam) (permissionDenied csrfErrorMessage)
+  unless (validHeader || validParam) $ do
+    $logWarnS "yesod-core" csrfErrorMessage
+    permissionDenied csrfErrorMessage
 
 validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
 -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
@@ -1414,4 +1458,4 @@ validCsrf Nothing            _param = True
 validCsrf (Just _token)     Nothing = False
 
 csrfErrorMessage :: Text
-csrfErrorMessage = "A valid CSRF token wasn't present in HTTP headers or POST parameters. Check the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."
+csrfErrorMessage = "A valid CSRF token wasn't present in HTTP headers or POST parameters. Because the request could have been forged, it's been rejected altogether. Check the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."

yesod-core/Yesod/Core/Internal/Session.hs

@@ -55,7 +55,7 @@ decodeClientSession key date rhost encrypted = do
 -- to preserve the type.
 
 clientSessionDateCacher ::
-     NominalDiffTime -- ^ Inactive session valitity.
+     NominalDiffTime -- ^ Inactive session validity.
   -> IO (IO ClientSessionDateCache, IO ())
 clientSessionDateCacher validity = do
     getClientSessionDateCache <- mkAutoUpdate defaultUpdateSettings

yesod-core/Yesod/Routes/Parse.hs

@@ -18,7 +18,7 @@ import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
 import Yesod.Routes.Overlap (findOverlapNames)
-import Data.List (foldl')
+import Data.List (foldl', isPrefixOf)
 import Data.Maybe (mapMaybe)
 import qualified Data.Set as Set
 
@@ -86,7 +86,7 @@ resourcesFromString =
         spaces = takeWhile (== ' ') thisLine
         (others, remainder) = parse indent otherLines'
         (this, otherLines') =
-            case takeWhile (/= "--") $ words thisLine of
+            case takeWhile (not . isPrefixOf "--") $ words thisLine of
                 (pattern:rest0)
                     | Just (constr:rest) <- stripColonLast rest0
                     , Just attrs <- mapM parseAttr rest ->

yesod-core/test/Hierarchy.hs

@@ -78,6 +78,8 @@ do
     let resources = [parseRoutes|
 / HomeR GET
 
+----------------------------------------
+
 /!#Int BackwardsR GET
 
 /admin/#Int AdminR:

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.19
+version:         1.4.20.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

yesod-form/README.md

@@ -2,3 +2,14 @@
 
 Form handling for Yesod, in the same style as formlets. See [the forms
 chapter](http://www.yesodweb.com/book/forms) of the Yesod book.
+
+This package provies a set of basic form inputs such as text, number, time,
+checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module.  Also,
+there is `Yesod.Form.Nic` module providing richtext field using Nic editor.
+However, this module is grandfathered now and Nic editor is not actively
+maintained since June 2012.  You can find additional richtext editor fields in
+[`yesod-form-richtext`][yesod-form-richtext] package (currently in provides
+support of [Summernote][summernote] editor only).
+
+[yesod-form-richtext]:http://hackage.haskell.org/package/yesod-form-richtext
+[summernote]:http://summernote.org/

yesod-form/Yesod/Form/Fields.hs

@@ -349,7 +349,7 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 
--- | Creates an input with @type="email"@ with the <http://www.w3.org/html/wg/drafts/html/master/forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
+-- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
 --
 -- Since 1.3.7
 multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]

yesod-form/Yesod/Form/Functions.hs

@@ -59,6 +59,7 @@ import Text.Blaze (Markup, toMarkup)
 #define Html Markup
 #define toHtml toMarkup
 import Yesod.Core
+import Yesod.Core.Handler (defaultCsrfParamName)
 import Network.Wai (requestMethod)
 import Text.Hamlet (shamlet)
 import Data.Monoid (mempty)
@@ -213,7 +214,7 @@ postHelper  :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
             -> m ((FormResult a, xml), Enctype)
 postHelper form env = do
     req <- getRequest
-    let tokenKey = "_token"
+    let tokenKey = defaultCsrfParamName
     let token =
             case reqToken req of
                 Nothing -> mempty

yesod-form/Yesod/Form/MassInput.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP#-}
+-- | A module providing a means of creating multiple input forms, such as a
+-- list of 0 or more recipients.
 module Yesod.Form.MassInput
     ( inputList
     , massDivs
@@ -40,11 +42,19 @@ up i = do
         IntCons _ is' -> put is' >> newFormIdent >> return ()
     up $ i - 1
 
+-- | Generate a form that accepts 0 or more values from the user, allowing the
+-- user to specify that a new row is necessary.
 inputList :: (m ~ HandlerT site IO, xml ~ WidgetT site IO (), RenderMessage site FormMessage)
           => Html
+          -- ^ label for the form
           -> ([[FieldView site]] -> xml)
+          -- ^ how to display the rows, usually either 'massDivs' or 'massTable'
           -> (Maybe a -> AForm (HandlerT site IO) a)
-          -> (Maybe [a] -> AForm (HandlerT site IO) [a])
+          -- ^ display a single row of the form, where @Maybe a@ gives the
+          -- previously submitted value
+          -> Maybe [a]
+          -- ^ default initial values for the form
+          -> AForm (HandlerT site IO) [a]
 inputList label fixXml single mdef = formToAForm $ do
     theId <- lift newIdent
     down 1

yesod-form/Yesod/Form/Nic.hs

@@ -4,6 +4,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 -- | Provide the user with a rich text editor.
+--
+-- According to NIC editor homepage it is not actively maintained since June
+-- 2012.  There is another better alternative — open sourced Summernote editor
+-- released under MIT licence.  You can use Summernote in your Yesod forms via
+-- separately distributed
+-- <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext>
+-- package.
 module Yesod.Form.Nic
     ( YesodNic (..)
     , nicHtmlField

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         1.4.6
+version:         1.4.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -10,7 +10,7 @@ stability:       Stable
 cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form>
+description:     API docs and the README are available at <http://www.stackage.org/package/yesod-form>.  Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currntly it provides only Summernote support).
 extra-source-files: ChangeLog.md
                     README.md
 
@@ -20,7 +20,7 @@ flag network-uri
 
 library
     build-depends:   base                  >= 4        && < 5
-                   , yesod-core            >= 1.4      && < 1.5
+                   , yesod-core            >= 1.4.14   && < 1.5
                    , yesod-persistent      >= 1.4      && < 1.5
                    , time                  >= 1.1.4
                    , shakespeare           >= 2.0
@@ -63,7 +63,7 @@ library
                      Yesod.Form.I18n.German
                      Yesod.Form.I18n.French
                      Yesod.Form.I18n.Norwegian
-                     Yesod.Form.I18n.Japanese
+                     Yesod.Form.I18n.Japanese
                      Yesod.Form.I18n.Czech
                      Yesod.Form.I18n.Russian
                      Yesod.Form.I18n.Dutch

yesod-persistent/yesod-persistent.cabal

@@ -1,5 +1,5 @@
 name:            yesod-persistent
-version:         1.4.0.3
+version:         1.4.0.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

yesod-test/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.5.1.0
+
+* Better error provenance for stuff invoking withResponse' [#1191](https://github.com/yesodweb/yesod/pull/1191)
+
 ## 1.5.0.1
 
 * Fixed the `application/x-www-form-urlencoded` header being added to all requests, even those sending a binary POST body [#1064](https://github.com/yesodweb/yesod/pull/1064/files)

yesod-test/Yesod/Test.hs

@@ -50,6 +50,7 @@ module Yesod.Test
     , get
     , post
     , postBody
+    , followRedirect
     , request
     , addRequestHeader
     , setMethod
@@ -277,15 +278,21 @@ yit label example = tell [YesodSpecItem label example]
 -- response-level assertions
 withResponse' :: MonadIO m
               => (state -> Maybe SResponse)
+              -> [T.Text]
               -> (SResponse -> ST.StateT state m a)
               -> ST.StateT state m a
-withResponse' getter f = maybe err f . getter =<< ST.get
+withResponse' getter errTrace f = maybe err f . getter =<< ST.get
- where err = failure "There was no response, you should make a request"
+ where err = failure msg
+       msg = if null errTrace
+             then "There was no response, you should make a request."
+             else
+               "There was no response, you should make a request. A response was needed because: \n - "
+               <> T.intercalate "\n - " errTrace
 
 -- | Performs a given action using the last response. Use this to create
 -- response-level assertions
 withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
-withResponse = withResponse' yedResponse
+withResponse = withResponse' yedResponse []
 
 -- | Use HXT to parse a value from an HTML tag.
 -- Check for usage examples in this module's source.
@@ -295,16 +302,17 @@ parseHTML html = fromDocument $ HD.parseLBS html
 -- | Query the last response using CSS selectors, returns a list of matched fragments
 htmlQuery' :: MonadIO m
            => (state -> Maybe SResponse)
+           -> [T.Text]
            -> Query
            -> ST.StateT state m [HtmlLBS]
-htmlQuery' getter query = withResponse' getter $ \ res ->
+htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->
   case findBySelector (simpleBody res) query of
     Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
     Right matches -> return $ map (encodeUtf8 . TL.pack) matches
 
 -- | Query the last response using CSS selectors, returns a list of matched fragments
 htmlQuery :: Query -> YesodExample site [HtmlLBS]
-htmlQuery = htmlQuery' yedResponse
+htmlQuery = htmlQuery' yedResponse []
 
 -- | Asserts that the two given values are equal.
 assertEqual :: (Eq a) => String -> a -> a -> YesodExample site ()
@@ -569,7 +577,7 @@ fileByLabel label path mime = do
 -- >   addToken_ "#formID"
 addToken_ :: Query -> RequestBuilder site ()
 addToken_ scope = do
-  matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]"
+  matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> "input[name=_token][type=hidden][value]"
   case matches of
     [] -> failure $ "No CSRF token found in the current page"
     element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element
@@ -686,6 +694,29 @@ get url = request $ do
     setMethod "GET"
     setUrl url
 
+-- | Follow a redirect, if the last response was a redirect.
+-- (We consider a request a redirect if the status is
+-- 301, 302, 303, 307 or 308, and the Location header is set.)
+--
+-- ==== __Examples__
+--
+-- > get HomeR
+-- > followRedirect
+followRedirect :: Yesod site
+               =>  YesodExample site (Either T.Text T.Text) -- ^ 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was
+followRedirect = do
+  mr <- getResponse
+  case mr of
+   Nothing ->  return $ Left "followRedirect called, but there was no previous response, so no redirect to follow"
+   Just r -> do
+     if not ((H.statusCode $ simpleStatus r) `elem` [301, 302, 303, 307, 308])
+       then return $ Left "followRedirect called, but previous request was not a redirect"
+       else do
+         case lookup "Location" (simpleHeaders r) of
+          Nothing -> return $ Left "followRedirect called, but no location header set"
+          Just h -> let url = TE.decodeUtf8 h in
+                     get url  >> return (Right url)
+
 -- | Sets the HTTP method used by the request.
 --
 -- ==== __Examples__

yesod-test/test/main.hs

@@ -20,11 +20,13 @@ import Data.Monoid ((<>))
 import Control.Applicative
 import Network.Wai (pathInfo, requestHeaders)
 import Data.Maybe (fromMaybe)
+import Data.Either (isLeft, isRight)
+import Control.Exception.Lifted(try, SomeException)
 
 import Data.ByteString.Lazy.Char8 ()
 import qualified Data.Map as Map
 import qualified Text.HTML.DOM as HD
-import Network.HTTP.Types.Status (unsupportedMediaType415)
+import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
 
 parseQuery_ = either error id . parseQuery
 findBySelector_ x = either error id . findBySelector x
@@ -213,8 +215,29 @@ main = hspec $ do
                 setMethod "POST"
                 setUrl ("/" :: Text)
             statusIs 403
+    describe "test redirects" $ yesodSpec app $ do
+        yit "follows 303 redirects when requested" $ do
+            get ("/redirect303" :: Text)
+            statusIs 303
+            r <- followRedirect
+            liftIO $ assertBool "expected a Right from a 303 redirect" $ isRight r
+            statusIs 200
+            bodyContains "we have been successfully redirected"
+
+        yit "follows 301 redirects when requested" $ do
+            get ("/redirect301" :: Text)
+            statusIs 301
+            r <- followRedirect
+            liftIO $ assertBool "expected a Right from a 301 redirect" $ isRight r
+            statusIs 200
+            bodyContains "we have been successfully redirected"
 
 
+        yit "returns a Left when no redirect was returned" $ do
+            get ("/" :: Text)
+            statusIs 200
+            r <- followRedirect
+            liftIO $ assertBool "expected a Left when not a redirect" $ isLeft r
 
 instance RenderMessage LiteApp FormMessage where
     renderMessage _ _ = defaultFormMessage
@@ -235,6 +258,9 @@ app = liteApp $ do
         case mfoo of
             Nothing -> error "No foo"
             Just foo -> return foo
+    onStatic "redirect301" $ dispatchTo $ redirectWith status301 ("/redirectTarget" :: Text) >> return ()
+    onStatic "redirect303" $ dispatchTo $ redirectWith status303 ("/redirectTarget" :: Text) >> return ()
+    onStatic "redirectTarget" $ dispatchTo $ return ("we have been successfully redirected" :: Text)
     onStatic "form" $ dispatchTo $ do
         ((mfoo, widget), _) <- runFormPost
                         $ renderDivs
@@ -290,4 +316,4 @@ postHomeR = defaultLayout
     [whamlet|
         <p>
             Welcome to my test application.
-    |]
+    |]

yesod-test/yesod-test.cabal

@@ -1,10 +1,10 @@
 name:               yesod-test
-version:            1.5.0.1
+version:            1.5.1.0
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
 maintainer:         Michael Snoyman, Greg Weber, Nubis <nubis@woobiz.com.ar>
-synopsis:           integration testing for WAI/Yesod Applications 
+synopsis:           integration testing for WAI/Yesod Applications
 category:           Web, Yesod, Testing
 stability:          Experimental
 cabal-version:      >= 1.8
@@ -60,6 +60,7 @@ test-suite test
                           , yesod-form
                           , text
                           , wai
+                          , lifted-base
                           , http-types
 
 source-repository head

yesod/yesod.cabal

@@ -1,5 +1,5 @@
 name:            yesod
-version:         1.4.2
+version:         1.4.2.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>