haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Works with newest yesod-core

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-30 19:57:43 +02:00
parent 734eb806ba
commit 49634531f1
1 changed files with 9 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Yesod/Form.hs
View File

@ -62,7 +62,7 @@ import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
import Data.Char (toUpper, isUpper) import Data.Char (toUpper, isUpper)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Data.List (group, sort) import Data.List (group, sort)
import Control.Monad.Trans.Class (lift) import Data.Monoid (mempty)
-- | Display only the actual input widget code, without any decoration. -- | Display only the actual input widget code, without any decoration.
fieldsToPlain :: FormField sub y a -> Form sub y a fieldsToPlain :: FormField sub y a -> Form sub y a
@ -112,8 +112,7 @@ fieldsToDivs = mapFormXml $ mapM_ go
-- | Run a form against POST parameters, without CSRF protection. -- | Run a form against POST parameters, without CSRF protection.
runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
runFormPostNoNonce f = do runFormPostNoNonce f = do
rr <- getRequest (pp, files) <- runRequestBody
(pp, files) <- lift $ reqRequestBody rr
runFormGeneric pp files f runFormGeneric pp files f
-- | Run a form against POST parameters. -- | Run a form against POST parameters.
@ -123,18 +122,17 @@ runFormPostNoNonce f = do
-- meaning of the fourth element in the tuple. -- meaning of the fourth element in the tuple.
runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)
runFormPost f = do runFormPost f = do
rr <- getRequest (pp, files) <- runRequestBody
(pp, files) <- lift $ reqRequestBody rr
nonce <- fmap reqNonce getRequest nonce <- fmap reqNonce getRequest
(res, xml, enctype) <- runFormGeneric pp files f (res, xml, enctype) <- runFormGeneric pp files f
let res' = let res' =
case res of case res of
FormSuccess x -> FormSuccess x ->
if lookup nonceName pp == Just nonce if lookup nonceName pp == nonce
then FormSuccess x then FormSuccess x
else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]
_ -> res _ -> res
return (res', xml, enctype, hidden nonce) return (res', xml, enctype, maybe mempty hidden nonce)
where where
hidden nonce = hidden nonce =
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
@ -152,8 +150,7 @@ nonceName = "_nonce"
-- CSRF protection. -- CSRF protection.
runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
runFormMonadPost f = do runFormMonadPost f = do
rr <- getRequest (pp, files) <- runRequestBody
(pp, files) <- lift $ reqRequestBody rr
runFormGeneric pp files f runFormGeneric pp files f
-- | Run a form against POST parameters, disregarding the resulting HTML and -- | Run a form against POST parameters, disregarding the resulting HTML and
@ -161,8 +158,7 @@ runFormMonadPost f = do
-- CSRF protection. -- CSRF protection.
runFormPost' :: GForm sub y xml a -> GHandler sub y a runFormPost' :: GForm sub y xml a -> GHandler sub y a
runFormPost' f = do runFormPost' f = do
rr <- getRequest (pp, files) <- runRequestBody
(pp, files) <- lift $ reqRequestBody rr
x <- runFormGeneric pp files f x <- runFormGeneric pp files f
helper x helper x
@ -233,7 +229,8 @@ generateForm f = do
#else #else
[$hamlet| [$hamlet|
#endif #endif
<input type="hidden" name="#{nonceName}" value="#{nonce}"> $maybe n <- nonce
<input type="hidden" name="#{nonceName}" value="#{n}">
|]) |])
-- | Run a form against GET parameters. -- | Run a form against GET parameters.