diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,34 @@ # ChangeLog for yesod-form +## 1.7.11 + +* Add `lookupRawFieldInput`, giving field views access to all raw + parameter values the named field was run against — whether from a + direct submission or a `runFormPRG` replay. The `Either Text a` + argument a view receives only carries the first submitted value, so + fields rendering several inputs under one name (e.g. a composite + amount-plus-currency field) previously could not restore the user's + input after a failed submission. + +## 1.7.10.1 + +* Move the `runFormPRG` integration tests to yesod-test's test suite, + removing yesod-form's test-suite dependency on yesod-test. That + dependency created a package-level cycle + (yesod-test → yesod-form → yesod-test) which broke the Stackage + build plan. [#1928](https://github.com/yesodweb/yesod/issues/1928) + +## 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 + ## 1.7.9.2 * Improve deprecation messages for `radioField` and `checkboxesField` [#1902](https://github.com/yesodweb/yesod/pull/1902) diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs --- a/Yesod/Form/Functions.hs +++ b/Yesod/Form/Functions.hs @@ -32,6 +32,8 @@ , runFormPost , runFormPostNoToken , runFormGet + -- ** Post\/Redirect\/Get + , runFormPRG -- * Generate a blank form , generateFormPost , generateFormGet' @@ -58,6 +60,7 @@ , convertField , addClass , removeClass + , lookupRawFieldInput ) where import Yesod.Form.Types @@ -67,16 +70,20 @@ 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 Data.IORef (IORef, newIORef, modifyIORef', readIORef) +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. @@ -222,6 +229,34 @@ -> MForm m (FormResult (Maybe a), FieldView site) mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False +-- | Per-request store of the raw parameter values each field was run +-- against, keyed by field name; see 'lookupRawFieldInput'. +newtype RawFieldInput = RawFieldInput (IORef (Map.Map Text [Text])) + +rawFieldInputRef :: MonadHandler m => m (IORef (Map.Map Text [Text])) +rawFieldInputRef = do + RawFieldInput ref <- cachedBy "yesod-form-raw-field-input" $ + fmap RawFieldInput $ liftIO $ newIORef Map.empty + return ref + +-- | The raw parameter values the named field was run against in this +-- request, whether from a direct submission or a Post\/Redirect\/Get +-- replay ('runFormPRG'). Empty if no form containing the field has run +-- with a submission in this request (e.g. 'generateFormPost', or an +-- 'identifyForm'-wrapped form that was not the one submitted). +-- +-- This lets the view of a field rendering several inputs under one name +-- restore all of the user's raw input after a failed submission: the +-- @Either Text a@ argument a view receives can only carry the first +-- submitted value. Only fields run through 'mreq'\/'mopt' (and the +-- applicative\/widget helpers built on them) record their values here. +-- +-- @since 1.7.11 +lookupRawFieldInput :: MonadHandler m => Text -> m [Text] +lookupRawFieldInput name = do + ref <- rawFieldInputRef + Map.findWithDefault [] name `liftM` liftIO (readIORef ref) + mhelper :: (site ~ HandlerSite m, MonadHandler m) => Field m a -> FieldSettings site @@ -245,6 +280,9 @@ mfs <- askFiles let mvals = fromMaybe [] $ Map.lookup name p files = fromMaybe [] $ mfs >>= Map.lookup name + lift $ do + ref <- rawFieldInputRef + liftIO $ modifyIORef' ref $ Map.insert name mvals emx <- lift $ fieldParse mvals files return $ case emx of Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals)) @@ -356,6 +394,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| +-- >
+-- > ^{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||] + 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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -7,7 +7,7 @@ import Yesod.Form.Types main :: IO () -main = hspec $ +main = hspec $ do 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) diff --git a/yesod-form.cabal b/yesod-form.cabal --- a/yesod-form.cabal +++ b/yesod-form.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-form -version: 1.7.9.2 +version: 1.7.11 license: MIT license-file: LICENSE author: Michael Snoyman @@ -39,7 +39,7 @@ , transformers >= 0.2.2 , wai >= 1.3 , xss-sanitize >= 0.3.0.1 - , yesod-core >= 1.6 && < 1.7 + , yesod-core >= 1.6 && < 1.8 , yesod-persistent >= 1.6 && < 1.7 if flag(network-uri)