yesod-form 1.7.9.3 → 1.7.10
raw patch · 5 files changed
+409/−4 lines, 5 filesdep +clientsessiondep +wai-extradep +yesod-testdep ~bytestringdep ~containersdep ~yesod-corenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: clientsession, wai-extra, yesod-test
Dependency ranges changed: bytestring, containers, yesod-core
API changes (from Hackage documentation)
+ Yesod.Form.Functions: runFormPRG :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m) => (Markup -> MForm m (FormResult a, xml)) -> m ((FormResult a, xml), Enctype)
Files
- ChangeLog.md +7/−0
- Yesod/Form/Functions.hs +147/−2
- test/PRGSpec.hs +243/−0
- test/main.hs +4/−1
- yesod-form.cabal +8/−1
ChangeLog.md view
@@ -1,5 +1,12 @@ # ChangeLog for yesod-form +## 1.7.10++* Add `runFormPRG`, a `runFormPost` variant for the+ Post/Redirect/Get pattern: failed submissions are stashed in the session+ and replayed (input and validation errors) by the next GET.+ [#1927](https://github.com/yesodweb/yesod/pull/1927)+ ## 1.7.9.3 * Support `yesod-core` 1.7
Yesod/Form/Functions.hs view
@@ -32,6 +32,8 @@ , runFormPost , runFormPostNoToken , runFormGet+ -- ** Post\/Redirect\/Get+ , runFormPRG -- * Generate a blank form , generateFormPost , generateFormGet'@@ -67,16 +69,19 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST) import Control.Monad.Trans.Writer (runWriterT, writer)-import Control.Monad (liftM, join)+import Control.Monad (liftM, join, when)+import qualified Data.Aeson as A import Data.Byteable (constEqBytes)+import qualified Data.ByteString.Lazy as BL import Text.Blaze (Markup, toMarkup) #define Html Markup #define toHtml toMarkup import Yesod.Core-import Network.Wai (requestMethod)+import Network.Wai (Request, requestMethod, rawPathInfo) import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE import Control.Arrow (first) -- | Get a unique identifier.@@ -356,6 +361,146 @@ => (Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype) generateFormPost form = first snd `liftM` postHelper form Nothing++-- | Run a form for the Post\/Redirect\/Get pattern, so that invalid input+-- and its validation errors survive a redirect.+--+-- Use this in /both/ the GET and POST handlers of a route, exactly as you+-- would 'runFormPost':+--+-- * On a POST request this behaves exactly like 'runFormPost' (including+-- CSRF protection). Additionally, on 'FormFailure' the submitted+-- parameters are stashed in the user session so that your handler can+-- simply 'redirect' back to the GET route instead of re-rendering. On+-- 'FormSuccess' any previously stashed parameters for this route are+-- cleared. On 'FormMissing' (another 'identifyForm'-wrapped form on the+-- page was the one submitted) the stash is left untouched.+--+-- * On a GET request, if stashed parameters exist for the current path,+-- they are removed from the session and the form is run against them:+-- the fields re-render with the user's input and validation errors, just+-- as a non-redirecting handler would have rendered them. A fresh CSRF+-- token is rendered into the form (the stashed token is discarded, and+-- no token check is performed on a replay). If nothing is stashed, this+-- behaves like 'generateFormPost' (the result is 'FormMissing').+--+-- > getRegisterR :: Handler Html+-- > getRegisterR = do+-- > ((_res, widget), enctype) <- runFormPRG personForm+-- > defaultLayout+-- > [whamlet|+-- > <form method=post action=@{RegisterR} enctype=#{enctype}>+-- > ^{widget}+-- > |]+-- >+-- > postRegisterR :: Handler Html+-- > postRegisterR = do+-- > ((res, _widget), _enctype) <- runFormPRG personForm+-- > case res of+-- > FormSuccess person -> do+-- > -- insert into the database, etc.+-- > setMessage "Registered!"+-- > redirect RegisterR+-- > _ -> redirect RegisterR+--+-- Notes and caveats:+--+-- * The stash is keyed by request path, so the GET and POST handlers must+-- share a route (the common Yesod pattern). Form pages on different+-- routes do not interfere with each other; two tabs on the /same/ path+-- share one stash (the last failed submission wins).+--+-- * Multiple forms on one page work when wrapped with 'identifyForm': on+-- replay, only the form that was actually submitted re-renders with+-- values and errors; the others return 'FormMissing' and render blank.+-- (The stash is popped once per request and shared between calls via+-- the per-request cache, so every form in the handler sees it.)+--+-- * Uploaded files are not stashed; file fields re-render empty after the+-- redirect.+--+-- * The stashed parameters live in the user session. With the default+-- client-session backend the whole session must fit in a cookie+-- (roughly 4KB), so this is unsuitable for very large forms. If the+-- stash fails to decode, it is discarded and a blank form is generated.+--+-- * If the application has no session backend, stashing is a no-op and+-- this degrades to 'runFormPost'\/'generateFormPost' semantics (input+-- will not survive the redirect).+--+-- * If your POST handler re-renders on failure instead of redirecting, do+-- not use this function: the stash would be consumed by an unrelated+-- later GET of the same path.+--+-- * On a replay the form may even produce 'FormSuccess' (e.g. a 'checkM'+-- validation whose outcome depends on external state); the result is+-- returned as-is. GET handlers normally use only the widget.+--+-- * A HEAD request reads the stash without consuming it, so that+-- middleware such as @autoHead@ does not eat the replay meant for the+-- subsequent GET.+--+-- @since 1.7.10+runFormPRG+ :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)+ => (Html -> MForm m (FormResult a, xml))+ -> m ((FormResult a, xml), Enctype)+runFormPRG form = do+ req <- getRequest+ let method = requestMethod $ reqWaiRequest req+ key = prgSessionKey $ reqWaiRequest req+ if method == "GET" || method == "HEAD"+ then do+ -- The per-request cache lets several calls in one handler+ -- (multiple forms on a page) all see the stash, even though it+ -- is deleted from the session on first read.+ PRGStash menv <- cachedBy (TE.encodeUtf8 key) $ do+ mbs <- lookupSessionBS key+ when (method /= "HEAD") $ deleteSession key+ return $ PRGStash $ mbs >>= A.decodeStrict+ case menv of+ Nothing -> postHelper form Nothing+ Just env -> replayHelper form env+ else do+ env <- postEnv+ res@((formRes, _), _) <- postHelper form env+ case (formRes, env) of+ (FormSuccess{}, _) -> deleteSession key+ (FormFailure{}, Just (params, _)) -> setSessionBS key $+ BL.toStrict $ A.encode $+ Map.delete defaultCsrfParamName params+ -- FormMissing means another identified form on this page+ -- was the one submitted; leave its stash alone.+ _ -> return ()+ return res++-- | Per-request cache wrapper for the Post\/Redirect\/Get stash; see+-- 'runFormPRG'.+newtype PRGStash = PRGStash (Maybe Env)++-- | Like 'postHelper', but runs the form against a supplied 'Env' (with an+-- empty 'FileEnv') instead of the current request body. A fresh CSRF token+-- fragment is rendered into the form, and no token check is performed: the+-- replayed submission was already checked by 'postHelper' when it was+-- stashed, and this run is a re-render, not a submission.+replayHelper :: MonadHandler m+ => (Html -> MForm m a)+ -> Env+ -> m (a, Enctype)+replayHelper form env = do+ req <- getRequest+ let token =+ case reqToken req of+ Nothing -> mempty+ Just n -> [shamlet|<input type=hidden name=#{defaultCsrfParamName} value=#{n}>|]+ m <- getYesod+ langs <- languages+ runFormGeneric (form token) m langs (Just (env, Map.empty))++-- | Session key for the Post\/Redirect\/Get stash, namespaced by request+-- path so that form pages on different routes do not interfere.+prgSessionKey :: Request -> Text+prgSessionKey req = "_PRG:" <> TE.decodeUtf8With TEE.lenientDecode (rawPathInfo req) postEnv :: MonadHandler m => m (Maybe (Env, FileEnv)) postEnv = do
+ test/PRGSpec.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Integration tests for 'runFormPRG'.+module PRGSpec (spec) where++import qualified Data.ByteString.Lazy as BL+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.Wai.Test (simpleBody)+import Test.Hspec (Spec)+import qualified Web.ClientSession as CS+import Yesod.Core+import Yesod.Form+import Yesod.Test++data App = App++mkYesod "App" [parseRoutes|+/form FormR GET POST+/two TwoR GET POST+/corrupt CorruptR GET+/stale StaleR GET+|]++instance Yesod App where+ -- A random key per test run, so no client_session_key.aes file is+ -- written into the repository.+ makeSessionBackend _ = do+ key <- snd `fmap` CS.randomKey+ (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (120 * 60)+ return $ Just $ clientSessionBackend key getCachedDate++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++fs :: Text -> FieldSettings App+fs name = FieldSettings (SomeMessage name) Nothing Nothing (Just name) []++personForm :: Html -> MForm Handler (FormResult (Text, Int), Widget)+personForm csrf = do+ (nameRes, nameView) <- mreq textField (fs "name") Nothing+ (ageRes, ageView) <- mreq ageField (fs "age") Nothing+ let widget = [whamlet|+ #{csrf}+ ^{fvInput nameView}+ $maybe err <- fvErrors nameView+ <p .error>#{err}+ ^{fvInput ageView}+ $maybe err <- fvErrors ageView+ <p .error>#{err}+ |]+ return ((,) <$> nameRes <*> ageRes, widget)+ where+ ageField = checkBool (>= (18 :: Int)) ("Too young" :: Text) intField++-- | A one-field form for the two-forms-on-a-page tests; submitting+-- non-numeric input fails with the input preserved.+numForm :: Text -> Html -> MForm Handler (FormResult Int, Widget)+numForm name csrf = do+ (res, view) <- mreq intField (fs name) Nothing+ let widget = [whamlet|+ #{csrf}+ ^{fvInput view}+ $maybe err <- fvErrors view+ <p .error>#{name}: #{err}+ |]+ return (res, widget)++getFormR :: Handler Html+getFormR = do+ mmsg <- getMessage+ ((_res, widget), enctype) <- runFormPRG personForm+ defaultLayout [whamlet|+ $maybe msg <- mmsg+ <p .message>#{msg}+ <form method=post action=@{FormR} enctype=#{enctype}>+ ^{widget}+ <button>go+ |]++postFormR :: Handler Html+postFormR = do+ ((res, _widget), _enctype) <- runFormPRG personForm+ case res of+ FormSuccess _ -> setMessage "registered" >> redirect FormR+ _ -> redirect FormR++getTwoR :: Handler Html+getTwoR = do+ mmsg <- getMessage+ ((_, fooW), fooE) <- runFormPRG $ identifyForm "foo" $ numForm "foonum"+ ((_, barW), barE) <- runFormPRG $ identifyForm "bar" $ numForm "barnum"+ defaultLayout [whamlet|+ $maybe msg <- mmsg+ <p .message>#{msg}+ <form method=post action=@{TwoR} enctype=#{fooE}>+ ^{fooW}+ <button>foo+ <form method=post action=@{TwoR} enctype=#{barE}>+ ^{barW}+ <button>bar+ |]++postTwoR :: Handler Html+postTwoR = do+ ((fooRes, _), _) <- runFormPRG $ identifyForm "foo" $ numForm "foonum"+ ((barRes, _), _) <- runFormPRG $ identifyForm "bar" $ numForm "barnum"+ case (fooRes, barRes) of+ (FormSuccess _, _) -> setMessage "foo ok" >> redirect TwoR+ (_, FormSuccess _) -> setMessage "bar ok" >> redirect TwoR+ _ -> redirect TwoR++-- | Plant garbage bytes where the stash for \/form lives.+getCorruptR :: Handler ()+getCorruptR = setSessionBS "_PRG:/form" "definitely not json"++-- | Plant a decodable stash for \/form, as if a submission with+-- name=stale had failed earlier.+getStaleR :: Handler ()+getStaleR = setSessionBS "_PRG:/form" "{\"name\":[\"stale\"],\"age\":[\"12\"]}"++-- | The CSRF token stays constant for a session, so grab it once from the+-- current response body and reuse it across requests. This avoids+-- 'addToken', which can only read the token from the /previous/ response.+extractToken :: YesodExample App Text+extractToken = do+ mres <- getResponse+ let body = maybe "" (TE.decodeUtf8 . BL.toStrict . simpleBody) mres+ (_, rest) = T.breakOn "name=\"_token\" value=\"" body+ case T.splitOn "\"" (T.drop (T.length "name=\"_token\" value=\"") rest) of+ (token:_) | not (T.null token) -> return token+ _ -> error "no _token in response body"++postParams :: Route App -> Text -> [(Text, Text)] -> YesodExample App ()+postParams route token params = request $ do+ setMethod "POST"+ setUrl route+ addPostParam "_token" token+ mapM_ (uncurry addPostParam) params++spec :: Spec+spec = yesodSpec App $+ ydescribe "runFormPRG" $ do+ yit "renders a blank form when nothing is stashed" $ do+ get FormR+ statusIs 200+ bodyContains "name=\"name\""+ bodyNotContains "error"++ yit "replays invalid input and errors after the redirect, once" $ do+ get FormR+ token <- extractToken+ postParams FormR token [("name", "alice"), ("age", "12")]+ statusIs 303+ get FormR+ statusIs 200+ bodyContains "value=\"alice\""+ bodyContains "value=\"12\""+ bodyContains "Too young"+ get FormR+ statusIs 200+ bodyNotContains "alice"+ bodyNotContains "Too young"++ yit "does not stash on success" $ do+ get FormR+ token <- extractToken+ postParams FormR token [("name", "alice"), ("age", "30")]+ statusIs 303+ get FormR+ statusIs 200+ bodyContains "registered"+ bodyNotContains "value=\"alice\""++ yit "success clears a stale stash" $ do+ get FormR+ token <- extractToken+ get StaleR+ postParams FormR token [("name", "alice"), ("age", "30")]+ statusIs 303+ get FormR+ statusIs 200+ bodyContains "registered"+ bodyNotContains "stale"++ yit "still enforces CSRF on POST" $ do+ get FormR+ postParams FormR "wrong-token" [("name", "alice"), ("age", "30")]+ statusIs 303+ get FormR+ statusIs 200+ bodyNotContains "registered"+ bodyContains "value=\"alice\""++ yit "replays only the submitted one of two identified forms" $ do+ get TwoR+ token <- extractToken+ postParams TwoR token+ [("_formid", "identify-foo"), ("foonum", "foo-banana")]+ statusIs 303+ get TwoR+ statusIs 200+ bodyContains "value=\"foo-banana\""+ bodyContains "foonum: "+ bodyNotContains "barnum: "++ yit "replays the second form on the page too" $ do+ get TwoR+ token <- extractToken+ postParams TwoR token+ [("_formid", "identify-bar"), ("barnum", "bar-banana")]+ statusIs 303+ get TwoR+ statusIs 200+ bodyContains "value=\"bar-banana\""+ bodyContains "barnum: "+ bodyNotContains "foonum: "++ yit "treats an undecodable stash as absent" $ do+ get CorruptR+ statusIs 200+ get FormR+ statusIs 200+ bodyContains "name=\"name\""++ yit "keys the stash by path" $ do+ get FormR+ token <- extractToken+ postParams FormR token [("name", "alice"), ("age", "12")]+ statusIs 303+ get TwoR+ statusIs 200+ bodyNotContains "alice"+ get FormR+ statusIs 200+ bodyContains "value=\"alice\""
test/main.hs view
@@ -6,8 +6,11 @@ import Yesod.Form.Fields (parseTime) import Yesod.Form.Types +import qualified PRGSpec+ main :: IO ()-main = hspec $+main = hspec $ do+ PRGSpec.spec describe "parseTime" $ mapM_ (\(s, e) -> it s $ parseTime (pack s) `shouldBe` e) [ ("01:00:00", Right $ TimeOfDay 1 0 0) , ("1:00", Right $ TimeOfDay 1 0 0)
yesod-form.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-form-version: 1.7.9.3+version: 1.7.10 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -77,11 +77,18 @@ type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test+ other-modules: PRGSpec build-depends: base , yesod-form , time , hspec , text+ , bytestring+ , clientsession+ , containers+ , wai-extra+ , yesod-core >= 1.6+ , yesod-test >= 1.6 source-repository head type: git