From 76fc5887f96dc698295c744539678e025838502b Mon Sep 17 00:00:00 2001
From: Alex Kardos <alexander.kardos@gmail.com>
Date: Wed, 17 Feb 2016 20:39:09 -0700
Subject: [PATCH] Fixed registerHandler CSRF issue

The default register handler for email authentication didn't provide a
CSRF token. I provided one by using a monadic form helper.
---
 yesod-auth/Yesod/Auth/Email.hs | 31 ++++++++++++++++++++++++++-----
 1 file changed, 26 insertions(+), 5 deletions(-)

diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs
index 1b94c411..6a3663ff 100644
--- a/yesod-auth/Yesod/Auth/Email.hs
+++ b/yesod-auth/Yesod/Auth/Email.hs
@@ -107,6 +107,8 @@ data EmailCreds site = EmailCreds
     , emailCredsEmail  :: Email
     }
 
+data UserForm = UserForm { email :: Text }
+
 class ( YesodAuth site
       , PathPiece (AuthEmailId site)
       , (RenderMessage site Msg.AuthMessage)
@@ -299,18 +301,37 @@ getRegisterR = registerHandler
 -- Since: 1.2.6
 defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
 defaultRegisterHandler = do
-    email <- newIdent
-    tp <- getRouteToParent
+    ((f,widget),e) <- lift $ runFormPost registrationForm
+    toParentRoute <- getRouteToParent
     lift $ authLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
             <p>_{Msg.EnterEmail}
-            <form method="post" action="@{tp registerR}">
+            <form method="post" action="@{toParentRoute registerR}">
                 <div id="registerForm">
-                    <label for=#{email}>_{Msg.Email}:
-                    <input ##{email} type="email" name="email" width="150" autofocus>
+                    ^{widget}
                 <button .btn>_{Msg.Register}
         |]
+    where
+        registrationForm extra = do
+            let emailSettings = FieldSettings {
+                fsLabel = "Email" ,
+                fsTooltip = Nothing ,
+                fsId = Just "email",
+                fsName = Just "email",
+                fsAttrs = []
+            }
+
+            (emailRes, emailView) <- mreq textField emailSettings Nothing
+
+            let userRes = UserForm <$> emailRes
+            let widget = do
+                [whamlet|
+                    #{extra}
+                    ^{fvInput emailView}
+                |]
+
+            return (userRes, widget)
 
 registerHelper :: YesodAuthEmail master
                => Bool -- ^ allow usernames?