From 1a752d4343a74d33ecd22f86141e2be88a7c733e Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 24 Oct 2010 22:26:33 +0200
Subject: [PATCH] Nonce for CSRF protection

---
 Yesod/Dispatch.hs     | 28 ++++++++++++++++++++++++++--
 Yesod/Form.hs         | 38 +++++++++++++++++++++++++++++++++-----
 Yesod/Helpers/Crud.hs |  3 ++-
 Yesod/Request.hs      |  2 ++
 hellowidget.hs        |  7 ++++++-
 5 files changed, 69 insertions(+), 9 deletions(-)

diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
index e9b46d72..73aaece9 100644
--- a/Yesod/Dispatch.hs
+++ b/Yesod/Dispatch.hs
@@ -68,6 +68,8 @@ import Network.Wai.Parse hiding (FileInfo)
 import qualified Network.Wai.Parse as NWP
 import Data.String (fromString)
 import Web.Routes
+import Control.Arrow (first)
+import System.Random (randomR, newStdGen)
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -264,7 +266,9 @@ toWaiApp' y segments env = do
     let eh er = runHandler (errorHandler' er) render eurl' id y id
     let ya = runHandler h render eurl' id y id
     (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types
-    let sessionVal = encodeSession key' exp' host sessionFinal
+    let sessionVal = encodeSession key' exp' host
+                   $ (nonceKey, reqNonce rr)
+                   : sessionFinal
     let hs' = AddCookie (clientSessionDuration y) sessionName
                                                   (bsToChars sessionVal)
             : hs
@@ -328,7 +332,27 @@ parseWaiRequest env session' = do
                      Nothing -> langs''
                      Just x -> x : langs''
     rbthunk <- iothunk $ rbHelper env
-    return $ Request gets' cookies' session' rbthunk env langs'''
+    nonce <- case lookup nonceKey session' of
+                Just x -> return x
+                Nothing -> do
+                    g <- newStdGen
+                    return $ fst $ randomString 10 g
+    return $ Request gets' cookies' session' rbthunk env langs''' nonce
+  where
+    randomString len =
+        first (map toChar) . sequence' (replicate len (randomR (0, 61)))
+    sequence' [] g = ([], g)
+    sequence' (f:fs) g =
+        let (f', g') = f g
+            (fs', g'') = sequence' fs g'
+         in (f' : fs', g'')
+    toChar i
+        | i < 26 = toEnum $ i + fromEnum 'A'
+        | i < 52 = toEnum $ i + fromEnum 'a' - 26
+        | otherwise = toEnum $ i + fromEnum '0' - 52
+
+nonceKey :: String
+nonceKey = "_NONCE"
 
 rbHelper :: W.Request -> IO RequestBodyContents
 rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where
diff --git a/Yesod/Form.hs b/Yesod/Form.hs
index c34d55e9..1a762dce 100644
--- a/Yesod/Form.hs
+++ b/Yesod/Form.hs
@@ -12,6 +12,8 @@ module Yesod.Form
     , FormFieldSettings (..)
     , Textarea (..)
     , FieldInfo (..)
+      -- ** Utilities
+    , formFailures
       -- * Type synonyms
     , Form
     , Formlet
@@ -92,13 +94,30 @@ fieldsToDivs = mapFormXml $ mapM_ go
     clazz fi = if fiRequired fi then "required" else "optional"
 
 -- | Run a form against POST parameters.
-runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
+--
+-- This function includes CSRF protection by checking a nonce value. You must
+-- therefore embed this nonce in the form as a hidden field; that is the
+-- meaning of the fourth element in the tuple.
+runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)
 runFormPost f = do
     rr <- getRequest
     (pp, files) <- liftIO $ reqRequestBody rr
-    runFormGeneric pp files f
+    nonce <- fmap reqNonce getRequest
+    (res, xml, enctype) <- runFormGeneric pp files f
+    let res' =
+            case res of
+                FormSuccess x ->
+                    if lookup nonceName pp == Just nonce
+                        then FormSuccess x
+                        else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]
+                _ -> res
+    return (res', xml, enctype, hidden nonce)
+  where
+    nonceName = "_nonce"
+    hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|]
 
--- | Run a form against POST parameters.
+-- | Run a form against POST parameters. Please note that this does not provide
+-- CSRF protection.
 runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
 runFormMonadPost f = do
     rr <- getRequest
@@ -106,9 +125,14 @@ runFormMonadPost f = do
     runFormGeneric pp files f
 
 -- | Run a form against POST parameters, disregarding the resulting HTML and
--- returning an error response on invalid input.
+-- returning an error response on invalid input. Note: this does /not/ perform
+-- CSRF protection.
 runFormPost' :: GForm sub y xml a -> GHandler sub y a
-runFormPost' = helper <=< runFormPost
+runFormPost' f = do
+    rr <- getRequest
+    (pp, files) <- liftIO $ reqRequestBody rr
+    x <- runFormGeneric pp files f
+    helper x
 
 -- | Run a form against GET parameters, disregarding the resulting HTML and
 -- returning an error response on invalid input.
@@ -225,3 +249,7 @@ toLabel (x:rest) = toUpper x : go rest
     go (c:cs)
         | isUpper c = ' ' : c : go cs
         | otherwise = c : go cs
+
+formFailures :: FormResult a -> Maybe [String]
+formFailures (FormFailure x) = Just x
+formFailures _ = Nothing
diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs
index e04afc32..5aebcae9 100644
--- a/Yesod/Helpers/Crud.hs
+++ b/Yesod/Helpers/Crud.hs
@@ -143,7 +143,7 @@ crudHelper
     -> GHandler (Crud master a) master RepHtml
 crudHelper title me isPost = do
     crud <- getYesodSub
-    (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me
+    (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me
     toMaster <- getRouteToMaster
     case (isPost, errs) of
         (True, FormSuccess a) -> do
@@ -166,6 +166,7 @@ crudHelper title me isPost = do
         ^form^
         %tr
             %td!colspan=2
+                $hidden$
                 %input!type=submit
                 $maybe me e
                     \ $
diff --git a/Yesod/Request.hs b/Yesod/Request.hs
index f89bc67b..f90973c7 100644
--- a/Yesod/Request.hs
+++ b/Yesod/Request.hs
@@ -108,6 +108,8 @@ data Request = Request
     , reqWaiRequest :: W.Request
       -- | Languages which the client supports.
     , reqLangs :: [String]
+      -- | A random, session-specific nonce used to prevent CSRF attacks.
+    , reqNonce :: String
     }
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
diff --git a/hellowidget.hs b/hellowidget.hs
index c8951dc4..fb408f13 100644
--- a/hellowidget.hs
+++ b/hellowidget.hs
@@ -61,7 +61,7 @@ getRootR = defaultLayout $ flip wrapWidget wrapper $ do
     addHead [$hamlet|%meta!keywords=haskell|]
 
 handleFormR = do
-    (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,)
+    (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,)
         <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing
         <*> stringField ("Another field") (Just "some default text")
         <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5)
@@ -103,7 +103,12 @@ textarea.html
     height: 150px
 |]
         wrapWidget form $ \h -> [$hamlet|
+$maybe formFailures.res failures
+    %ul.errors
+        $forall failures f
+            %li $f$
 %form!method=post!enctype=$enctype$
+    $hidden$
     %table
         ^h^
         %tr